unit DropSource;

// -----------------------------------------------------------------------------
// Project:	Drag and Drop source
// Module:	DropSource
// Description:	Simple implementation of a DropSource object
// Version:	2.0
// Release:	2
// Date:	14-MAR-1998
// Target:	Win32, Delphi 3
// Author:	Anders Melander, anders@melander.dk
// Copyright	(c) 1997,98 by Anders Melander
// Formatting:	2 space indent, 8 space tabs, 80 columns.
// -----------------------------------------------------------------------------
// Portions copyright (c) Borland International.
// -----------------------------------------------------------------------------
// You are free to use the source in any way you please, but please give
// me credit for my work.
// If you make improvements (as I'm sure you will have to) or derive new
// components from my stuff, I would very much like to see your improvements.
// -----------------------------------------------------------------------------
// Revision history:
//
// 0100	290597	anme	- Initial attempt based on clues from jape@planetmail.net
//
// 0101	030697	anme	- Yet another attempt. Copied a lot of stuff from
//			  ContextM.pas - Close, but no cigar.
//
// 0102	100697	anme	- Hmmm - maybe I shouldn't delete my object after
//			  calling DoDragDrop. OK, that got rid of a GPF,
//			  but still no drop.
//
// 0103	100697	anme    - Found stuff from stefc@fabula.com, looks like he's had
//			  the same problems. Adapted GetData from his source.
//			  Aha! I _do_ need to implement EnumFormatEtc after all.
//			  Copied TEnumFormatEtc from OleCtnrs.pas and... Voila!
//
// 0104	160697	anme    - Modified TDropSource to handle CF_HDROP instead of
//			  CF_TEXT just for the fun of it...
//			  OLE initialization was missing, so when I removed the
//			  memo field from the test form, the demo stopped
//			  working.
//			  Works nicely, but can't get DROPEFFECT_LINK to play.
//
// 0200	140398	anme	- Remodelled design.
//			  TDropSource is now an abstract base class from which
//			  TDropTextSource and TDropFileSource is derived.
//			- Changed TDropSource base class from TComObject to
//			  TInterfacedObject. We don't need support for object
//			  factories.
// -----------------------------------------------------------------------------

interface
uses
  Windows,
  ComObj,
  ActiveX,
  classes;

type
  TDropSource = class(TInterfacedObject, IDropSource, IDataObject)
  private
  protected
    function DoGetData(const formatetcIn: TFormatEtc; out medium: TStgMedium): HResult; virtual;
    function DoGetDataHere(const formatetc: TFormatEtc; out medium: TStgMedium): HResult; virtual;
    function DoQueryGetData(const formatetc: TFormatEtc): HResult; virtual; abstract;
    function DoEnumFormatEtc(dwDirection: Longint; out enumFormatEtc: IEnumFormatEtc): HResult; virtual; abstract;
  public
      // IDropSource implementation
    function QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: Longint): HResult; stdcall;
    function GiveFeedback(dwEffect: Longint): HResult; stdcall;

      // IDataObject implementation
    function GetData(const formatetcIn: TFormatEtc; out medium: TStgMedium): HResult; stdcall;
    function GetDataHere(const formatetc: TFormatEtc; out medium: TStgMedium): HResult; stdcall;
    function QueryGetData(const formatetc: TFormatEtc): HResult; stdcall;
    function GetCanonicalFormatEtc(const formatetc: TFormatEtc;
      out formatetcOut: TFormatEtc): HResult; stdcall;
    function SetData(const formatetc: TFormatEtc; var medium: TStgMedium;
      fRelease: BOOL): HResult; stdcall;
    function EnumFormatEtc(dwDirection: Longint; out enumFormatEtc: IEnumFormatEtc): HResult; stdcall;
    function DAdvise(const formatetc: TFormatEtc; advf: Longint;
      const advSink: IAdviseSink; out dwConnection: Longint): HResult; stdcall;
    function DUnadvise(dwConnection: Longint): HResult; stdcall;
    function EnumDAdvise(out enumAdvise: IEnumStatData): HResult; stdcall;
  end;

  TDropTextSource = class(TDropSource, IDropSource, IDataObject)
  private
    FText: string;
  protected
    function DoGetData(const formatetcIn: TFormatEtc; out medium: TStgMedium): HResult; override;
    function DoGetDataHere(const formatetc: TFormatEtc; out medium: TStgMedium): HResult; override;
    function DoQueryGetData(const formatetc: TFormatEtc): HResult; override;
    function DoEnumFormatEtc(dwDirection: Longint; out enumFormatEtc: IEnumFormatEtc): HResult; override;
  public
    constructor Create;
    destructor Destroy; override;
    property Text: string read FText write FText;
  end;

  TDropFileSource = class(TDropSource, IDropSource, IDataObject)
  private
    FFiles: TStrings;
  protected
    function DoGetData(const formatetcIn: TFormatEtc; out medium: TStgMedium): HResult; override;
    function DoGetDataHere(const formatetc: TFormatEtc; out medium: TStgMedium): HResult; override;
    function DoQueryGetData(const formatetc: TFormatEtc): HResult; override;
    function DoEnumFormatEtc(dwDirection: Longint; out enumFormatEtc: IEnumFormatEtc): HResult; override;
  public
    constructor Create;
    constructor CreateFilename(const Filename: string);
    constructor CreateFileList(Filenames: TStrings);
    destructor Destroy; override;
    property Files: TStrings read FFiles;
  end;

implementation

uses
  ComServ,
  ShlObj,
  SysUtils;

// -----------------------------------------------------------------------------
//			TEnumFormatEtc
// -----------------------------------------------------------------------------
{ TEnumFormatEtc - format enumerator for TDataObject }

type
  PFormatList = ^TFormatList;
  TFormatList = array[0..255] of TFormatEtc;

type
  // TEnumFormatEtc was "stolen" from OleCtnrs.pas
  TEnumFormatEtc = class(TInterfacedObject, IEnumFormatEtc)
  private
    FFormatList: PFormatList;
    FFormatCount: Integer;
    FIndex: Integer;
  public
    constructor Create(FormatList: PFormatList; FormatCount, Index: Integer);
    { IEnumFormatEtc }
    function Next(celt: Longint; out elt; pceltFetched: PLongint): HResult; stdcall;
    function Skip(celt: Longint): HResult; stdcall;
    function Reset: HResult; stdcall;
    function Clone(out enum: IEnumFormatEtc): HResult; stdcall;
  end;

constructor TEnumFormatEtc.Create(FormatList: PFormatList;
  FormatCount, Index: Integer);
begin
  inherited Create;
  FFormatList := FormatList;
  FFormatCount := FormatCount;
  FIndex := Index;
end;

function TEnumFormatEtc.Next(celt: Longint; out elt; pceltFetched: PLongint): HResult;
var
  I: Integer;
begin
  I := 0;
  while (I < celt) and (FIndex < FFormatCount) do
  begin
    TFormatList(elt)[I] := FFormatList[FIndex];
    Inc(FIndex);
    Inc(I);
  end;
  if pceltFetched <> nil then pceltFetched^ := I;
  if I = celt then Result := S_OK else Result := S_FALSE;
end;

function TEnumFormatEtc.Skip(celt: Longint): HResult;
begin
  if celt <= FFormatCount - FIndex then
  begin
    FIndex := FIndex + celt;
    Result := S_OK;
  end else
  begin
    FIndex := FFormatCount;
    Result := S_FALSE;
  end;
end;

function TEnumFormatEtc.Reset: HResult;
begin
  FIndex := 0;
  Result := S_OK;
end;

function TEnumFormatEtc.Clone(out enum: IEnumFormatEtc): HResult;
begin
  enum := TEnumFormatEtc.Create(FFormatList, FFormatCount, FIndex);
  Result := S_OK;
end;

// -----------------------------------------------------------------------------
//			TDropSource
// -----------------------------------------------------------------------------

function TDropSource.QueryContinueDrag(fEscapePressed: BOOL;
  grfKeyState: Longint): HResult; stdcall;
begin
  if (fEscapePressed) then
    Result := DRAGDROP_S_CANCEL
  else
    if (grfKeyState and (MK_LBUTTON or MK_RBUTTON) = 0) then
      Result := DRAGDROP_S_DROP
    else
      Result := NOERROR;
end;

function TDropSource.GiveFeedback(dwEffect: Longint): HResult; stdcall;
begin
  Result := DRAGDROP_S_USEDEFAULTCURSORS;
end;

function TDropSource.GetCanonicalFormatEtc(const formatetc: TFormatEtc;
  out formatetcOut: TFormatEtc): HResult;
begin
  formatetcOut.ptd := nil;
  Result := E_NOTIMPL;
end;

function TDropSource.SetData(const formatetc: TFormatEtc; var medium: TStgMedium;
  fRelease: BOOL): HResult;
begin
  Result := E_NOTIMPL;
end;

function TDropSource.DAdvise(const formatetc: TFormatEtc; advf: Longint;
  const advSink: IAdviseSink; out dwConnection: Longint): HResult;
begin
  Result := OLE_E_ADVISENOTSUPPORTED;
end;

function TDropSource.DUnadvise(dwConnection: Longint): HResult;
begin
  Result := OLE_E_ADVISENOTSUPPORTED;
end;

function TDropSource.EnumDAdvise(out enumAdvise: IEnumStatData): HResult;
begin
  Result := OLE_E_ADVISENOTSUPPORTED;
end;

function TDropSource.GetData(const formatetcIn: TFormatEtc; out medium: TStgMedium): HResult; stdcall;
begin
  Result := DoGetData(formatetcIn, medium);
end;

function TDropSource.GetDataHere(const formatetc: TFormatEtc;
  out medium: TStgMedium): HResult; stdcall;
begin
  Result := DoGetDataHere(formatetc, medium);
end;

function TDropSource.QueryGetData(const formatetc: TFormatEtc): HResult; stdcall;
begin
  Result := DoQueryGetData(formatetc);
end;

function TDropSource.EnumFormatEtc(dwDirection: Longint;
  out enumFormatEtc: IEnumFormatEtc): HResult; stdcall;
begin
  Result := DoEnumFormatEtc(dwDirection, enumFormatEtc);
end;

function TDropSource.DoGetData(const formatetcIn: TFormatEtc; out medium: TStgMedium): HResult;
begin
  Result := DV_E_FORMATETC;
end;

function TDropSource.DoGetDataHere(const formatetc: TFormatEtc;
  out medium: TStgMedium): HResult;
begin
  Result := DV_E_FORMATETC;
end;

// -----------------------------------------------------------------------------
//			TDropTextSource
// -----------------------------------------------------------------------------

constructor TDropTextSource.Create;
begin
  inherited Create;
  FText := '';
end;

destructor TDropTextSource.Destroy;
begin
  inherited Destroy;
end;

function TDropTextSource.DoGetDataHere(const formatetc: TFormatEtc; out medium: TStgMedium): HResult;
var
  pText: PChar;
begin
  if (formatetc.cfFormat = CF_TEXT) and
    (formatetc.dwAspect = DVASPECT_CONTENT) and
    (formatetc.tymed = TYMED_HGLOBAL) and (medium.tymed = TYMED_HGLOBAL) then
  begin
    if (medium.hGlobal = 0) then
    begin
      Result := E_OUTOFMEMORY;
      exit;
    end;
    pText := PChar(GlobalLock(medium.hGlobal));
    try
      StrCopy(pText, PChar(FText));
    finally
      GlobalUnlock(medium.hGlobal);
    end;
    medium.UnkForRelease := nil;
    Result := S_OK;
  end else
    Result := inherited DoGetDataHere(formatetc, medium);
end;

// Adapted from stefc@fabula.com

function TDropTextSource.DoGetData(const formatetcIn: TFormatEtc; out medium: TStgMedium): HResult;
begin
  medium.tymed := 0;
  medium.UnkForRelease := nil;
  medium.hGlobal := 0;

  if (formatetcIn.cfFormat = CF_TEXT) and
    (formatetcIn.dwAspect = DVASPECT_CONTENT) and
    (formatetcIn.tymed = TYMED_HGLOBAL) then
  begin
    medium.hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, Length(FText) + 1);
    if (medium.hGlobal = 0) then
    begin
      Result := E_OUTOFMEMORY;
      exit;
    end;
    medium.tymed := TYMED_HGLOBAL;
    Result := DoGetDataHere(formatetcIn, medium);
  end else
    Result := DV_E_FORMATETC;
end;

function TDropTextSource.DoQueryGetData(const formatetc: TFormatEtc): HResult;
begin
  // This method is called by the drop target to check whether the source
  // provides data in a format that the target accepts.
  if (formatetc.cfFormat = CF_TEXT) and
    (formatetc.dwAspect = DVASPECT_CONTENT) and
    (formatetc.tymed = TYMED_HGLOBAL) then
    Result := S_OK
  else
    Result := S_FALSE;
end;

const
  TextDataFormatCount = 1;
var
  TextDataFormats: array[0..TextDataFormatCount - 1] of TFormatEtc;

function TDropTextSource.DoEnumFormatEtc(dwDirection: Longint;
  out enumFormatEtc: IEnumFormatEtc): HResult;
begin
  if (dwDirection = DATADIR_GET) then
  begin
    TextDataFormats[0].cfFormat := CF_TEXT;
    TextDataFormats[0].dwAspect := DVASPECT_CONTENT;
    TextDataFormats[0].lIndex := -1;
    TextDataFormats[0].tymed := TYMED_HGLOBAL;
    enumFormatEtc := TEnumFormatEtc.Create(@TextDataFormats, TextDataFormatCount, 0);
    Result := S_OK;
  end else
    if (dwDirection = DATADIR_SET) then
      Result := E_NOTIMPL
    else
      Result := E_INVALIDARG;
end;

// -----------------------------------------------------------------------------
//			TDropFileSource
// -----------------------------------------------------------------------------
type
  TMyDropFiles = packed record
    DropFiles: TDropFiles;
    Filenames: array[1..1] of char;
  end;
  PMyDropFiles = ^TMyDropFiles;

constructor TDropFileSource.Create;
begin
  inherited Create;
  FFiles := TStringList.Create;
end;

constructor TDropFileSource.CreateFilename(const Filename: string);
begin
  inherited Create;
  FFiles := TStringList.Create;
  FFiles.Add(Filename);
end;

constructor TDropFileSource.CreateFileList(Filenames: TStrings);
begin
  inherited Create;
  FFiles := TStringList.Create;
  FFiles.Assign(Filenames);
end;

destructor TDropFileSource.Destroy;
begin
  FFiles.Free;

  inherited Destroy;
end;

function TDropFileSource.DoGetDataHere(const formatetc: TFormatEtc; out medium: TStgMedium): HResult;
var
  i: integer;
  DropFiles: PMyDropFiles;
  pText: PChar;
begin
  if (formatetc.cfFormat = CF_HDROP) and
    ((formatetc.dwAspect = DVASPECT_CONTENT) or (formatetc.dwAspect = DVASPECT_ICON)) and
    (formatetc.tymed = TYMED_HGLOBAL) and (medium.tymed = TYMED_HGLOBAL) then
  begin
    if (medium.hGlobal = 0) then
    begin
      Result := E_OUTOFMEMORY;
      exit;
    end;
    DropFiles := GlobalLock(medium.hGlobal);
    try
      DropFiles^.DropFiles.pFiles := sizeof(TDropFiles);
      DropFiles^.DropFiles.fWide := False;
      pText := @(DropFiles^.Filenames);
      for i := 0 to FFiles.Count - 1 do
      begin
        StrPCopy(pText, FFiles[i]);
        inc(pText, length(FFiles[i]) + 1);
      end;
      pText^ := #0;
    finally
      GlobalUnlock(medium.hGlobal);
    end;
    medium.UnkForRelease := nil;
    Result := S_OK;
  end else
    Result := inherited DoGetDataHere(formatetc, medium);
end;

function TDropFileSource.DoGetData(const formatetcIn: TFormatEtc; out medium: TStgMedium): HResult;
var
  i: integer;
  StrLength: integer;
begin
  medium.tymed := 0;
  medium.UnkForRelease := nil;
  medium.hGlobal := 0;

  if (formatetcIn.cfFormat = CF_HDROP) and
    ((formatetcIn.dwAspect = DVASPECT_CONTENT) or (formatetcIn.dwAspect = DVASPECT_ICON)) and
    (formatetcIn.tymed = TYMED_HGLOBAL) then
  begin
    StrLength := 0;
    for i := 0 to FFiles.Count - 1 do
      inc(StrLength, Length(FFiles[i]) + 1);
    medium.hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, Sizeof(TDropFiles) + StrLength + 1);
    if (medium.hGlobal = 0) then
    begin
      Result := E_OUTOFMEMORY;
      exit;
    end;
    medium.tymed := TYMED_HGLOBAL;
    Result := DoGetDataHere(formatetcIn, medium);
  end else
    Result := DV_E_FORMATETC;
end;

function TDropFileSource.DoQueryGetData(const formatetc: TFormatEtc): HResult;
begin
  // This method is called by the drop target to check whether the source
  // provides data in a format that the target accepts.
  if (formatetc.cfFormat = CF_HDROP) and
    ((formatetc.dwAspect = DVASPECT_CONTENT) or (formatetc.dwAspect = DVASPECT_ICON)) and
    (formatetc.tymed = TYMED_HGLOBAL) then
    Result := S_OK
  else
    Result := S_FALSE;
end;

const
  FileDataFormatCount = 2;
var
  FileDataFormats: array[0..FileDataFormatCount - 1] of TFormatEtc;

function TDropFileSource.DoEnumFormatEtc(dwDirection: Longint;
  out enumFormatEtc: IEnumFormatEtc): HResult;
begin
  if (dwDirection = DATADIR_GET) then
  begin
    FileDataFormats[0].cfFormat := CF_HDROP;
    FileDataFormats[0].dwAspect := DVASPECT_CONTENT;
    FileDataFormats[0].lIndex := -1;
    FileDataFormats[0].tymed := TYMED_HGLOBAL;
    FileDataFormats[1].cfFormat := CF_HDROP;
    FileDataFormats[1].dwAspect := DVASPECT_ICON;
    FileDataFormats[1].lIndex := -1;
    FileDataFormats[1].tymed := TYMED_HGLOBAL;
    enumFormatEtc := TEnumFormatEtc.Create(@FileDataFormats, FileDataFormatCount, 0);
    Result := S_OK;
  end else
    if (dwDirection = DATADIR_SET) then
      Result := E_NOTIMPL
    else
      Result := E_INVALIDARG;
end;

initialization
  OleInitialize(nil);
finalization
  OleUninitialize;

end.
