unit FileDropSource;

interface

uses
  Windows, Classes, ActiveX, ShlObj, ClipBrd;

const
   MAX_NUM_FORMAT = 5;

type
   pFormatList = ^TFormatList;
   TFormatList = array[0..MAX_NUM_FORMAT] of TFormatEtc;

   pMediumList = ^TMediumList;
   TMediumList = array[0..MAX_NUM_FORMAT] of TStgMedium;

   TCreateFileGroup = function : HGLOBAL of object;
   TCreateFileContents = function (nItem : Integer) : HGLOBAL of object;
   TCreateFileContents2 = function (nItem : Integer) : String of object;


   TInterfacedComponent = class(TComponent, IUnknown)
   private
      fRefCount: Integer;
   protected
      function QueryInterface(const IID: TGuid; out Obj): HRESULT; override; StdCall;
      function _AddRef: Integer; StdCall;
      function _Release: Integer; StdCall;
   public
      property RefCount: Integer read fRefCount;
   end;

   TDropSource = class(TInterfacedComponent, IDropSource, IDataObject)
   private
      m_cFormatsAvailable : Integer;
      m_strFormatEtc : TFormatList;
      m_strStgMedium : TMediumList;

     g_cfFileContents        : Integer;
     g_cfFileGroupDescriptor : Integer;
   protected
      // 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;

   public
      fOnCreateFileGroup      : TCreateFileGroup;
      fOnCreateFileContents   : TCreateFileContents;


      constructor Create(aowner: TComponent); override;
      function Execute : Integer;//TDragResult;
      function CopyToClipboard: boolean; virtual;
   end;

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


   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;


implementation

//////////////////////////////
//                          //
//                          //
// TInterfacedComponent     //
//                          //
//                          //
//////////////////////////////

function TInterfacedComponent.QueryInterface(const IID: TGuid; out Obj): HRESULT;
begin
   if GetInterface(IID, Obj) then
   begin
      Result := 0
   end
   else
   begin
      Result := E_NOINTERFACE;
   end;
end;


function TInterfacedComponent._AddRef: Integer;
begin
   Inc(fRefCount);
   Result := fRefCount;
end;

function TInterfacedComponent._Release: Integer;
begin
   Dec(fRefCount);
   if fRefCount = 0 then
   begin
      Destroy;
      result := 0;
      Exit;
   end;
   result := fRefCount;
end;

//////////////////////////////
//                          //
//                          //
// TDropSource              //
//                          //
//                          //
//////////////////////////////


constructor TDropSource.Create(aOwner: TComponent);
begin
   inherited Create(aOwner);
//   DragTypes := [dtCopy]; //default to Copy.
   //To avoid premature release ...
   _AddRef;
   m_cFormatsAvailable := 0;

   // Get the ID's of the formats we need
   g_cfFileContents        := RegisterClipboardFormat(CFSTR_FILECONTENTS);
   g_cfFileGroupDescriptor := RegisterClipboardFormat(CFSTR_FILEDESCRIPTOR);

   fOnCreateFileGroup      := nil;
   fOnCreateFileContents   := nil;
end;

function TDropSource.Execute: Integer;
var
   res      : HRESULT;
   effect   : LongInt;
   fe       : FORMATETC;
   stm      : STGMEDIUM;
begin
   Result := 0;//drUnknown;

   ZeroMemory(@stm, sizeof(stm));
   ZeroMemory(@fe, sizeof(fe));

   // File Contents
//   stm.tymed := TYMED_FILE;
   stm.tymed := TYMED_HGLOBAL;
//   stm.lpszFileName := nil; // data will be provided in DataObject::GetData delayed rendering
   stm.hGlobal := 0;// delayed rendering

//	fe.tymed    := TYMED_FILE;
	fe.tymed    := TYMED_HGLOBAL;
	fe.ptd      := nil;
	fe.lindex   := -1;
	fe.dwAspect := DVASPECT_CONTENT;
   fe.cfFormat := g_cfFileContents;
   SetData(fe, stm, True);

   // File Group descriptor
   stm.tymed := TYMED_HGLOBAL;
   stm.hGlobal := 0; // data will be provided in DataObject::GetData delayed rendering

	fe.tymed    := TYMED_HGLOBAL;
	fe.ptd      := nil;
	fe.lindex   := -1;
	fe.dwAspect := DVASPECT_CONTENT;
   fe.cfFormat := g_cfFileGroupDescriptor;
   SetData(fe,stm,TRUE);

////

   res := DoDragDrop(Self as IDataObject, Self as IDropSource, DROPEFFECT_COPY, effect);
   case res of
      DRAGDROP_S_DROP:
         Result := 1;

      DRAGDROP_S_CANCEL:
         result := 0;//drCancel;

      E_OUTOFMEMORY:
         result := -1;//drOutMemory;
   end;
end;

function TDropSource.CopyToClipboard: boolean;
begin
   result := false;
end;

// IDropSource implementation
function TDropSource.QueryContinueDrag(fEscapePressed: bool; grfKeyState: LongInt): HRESULT; StdCall;
begin
   Result := S_OK; // default

   if fEscapePressed then
   begin
      Result := DRAGDROP_S_CANCEL
   end
   else
   begin
      if (grfKeyState and (MK_LBUTTON or MK_RBUTTON)) = 0 then
      begin
         Result := DRAGDROP_S_DROP;
      end;
   end;
end;

function TDropSource.GiveFeedback(dwEffect: LongInt): HRESULT; StdCall;
begin
   Result := DRAGDROP_S_USEDEFAULTCURSORS;
end;

// IDataObject implementation
function TDropSource.GetCanonicalFormatEtc(const FormatEtc: TFormatEtc; out FormatEtcOut: TFormatEtc): HRESULT;
begin
   Result := DATA_S_SAMEFORMATETC;
end;

function TDropSource.SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; fRelease: Bool): HRESULT;
var
   i : Integer;
begin
   if not fRelease then
   begin
      Result := E_FAIL;
      exit;
   end;

{   if(pFE == NULL &&  pSTM == NULL)
   begin
      return E_INVALIDARG;
   end}

   i := 0;
   if m_cFormatsAvailable > 0 then
   begin
      for i := 0 to m_cFormatsAvailable - 1 do
      begin
         if m_strFormatEtc[i].cfFormat = FormatEtc.cfFormat then
         begin
            m_strStgMedium[i] := Medium;//*pSTM;
            m_strFormatEtc[i] := FormatEtc;//*pFE;
         end;
      end;
   end;

   if i < MAX_NUM_FORMAT then
   begin
   	m_strStgMedium[i] := Medium;
   	m_strFormatEtc[i] := FormatEtc;
	   inc(m_cFormatsAvailable);
	   Result := S_OK;
   end
   else
   begin
   	Result := E_OUTOFMEMORY;
   end;
end;


function TDropSource.EnumDAdvise(OUT EnumAdvise: IEnumStatData): HRESULT;
begin
   Result := OLE_E_ADVISENOTSUPPORTED;
end;

function TDropSource.DAdvise(const FormatEtc: TFormatEtc; advf: LongInt; const advSink: IAdviseSink; OUT dwConnection: LongInt): HRESULT;
begin
   Result := E_NOTIMPL;
end;

function TDropSource.DUnadvise(dwConnection: LongInt): HRESULT;
begin
    result := E_NOTIMPL;
end;

function TDropSource.GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium):HRESULT; StdCall;
var
   i : Integer;
begin
// check for valid arguments......?

	Medium.hGlobal := 0;
   for i := 0 to m_cFormatsAvailable - 1 do
   begin
		if ((FormatEtcIn.tymed and m_strFormatEtc[i].tymed) > 0) and
			(FormatEtcIn.dwAspect = m_strFormatEtc[i].dwAspect) and
			(FormatEtcIn.cfFormat = m_strFormatEtc[i].cfFormat) then
      begin
			Medium.tymed := m_strStgMedium[i].tymed;

			if FormatEtcIn.cfFormat = g_cfFileGroupDescriptor then
			begin
            if Assigned(fOnCreateFileGroup) then
            begin
               Medium.hGlobal := fOnCreateFileGroup;
            end
            else
            begin
               Medium.hGlobal := 0;
            end;

            if Medium.hGlobal <> 0 then
            begin
               Medium.tymed := TYMED_HGLOBAL;
				   Result := S_OK;
               exit;
            end
			end;
			if FormatEtcIn.cfFormat = g_cfFileContents then
			begin
//            OutputDebugString("CImpIDataObject::GetData() - FileContents\n");
				//Medium.hGlobal := CreateFileContents(FormatEtcIn.lindex);
            if Assigned(fOnCreateFileContents) then
            begin
               Medium.hGlobal := fOnCreateFileContents(FormatEtcIn.lindex);


               {FileName := fOnCreateFileContents(FormatEtcIn.lindex);
               // Convert the file name into a wide char string
               WFileName := FileName;

               Medium.lpszFileName := PWideChar(WFileName);}
            end
            else
            begin
               Medium.hGlobal := 0;
            end;
            
            if Medium.hGlobal <> 0 then
            begin
               Medium.tymed := TYMED_HGLOBAL;
				   Result := S_OK;
               exit;
            end;
			end
		end
	end;
	Result := DV_E_FORMATETC;
end;

  //******************* TDropSource.GetDataHere *************************
function TDropSource.GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium):HRESULT; StdCall;
begin
(*
   if(pFE == NULL ||pSM == NULL)
   {
      return E_INVALIDARG;
   }

   return E_NOTIMPL;
*)
   Result := E_NOTIMPL;
end;

function TDropSource.QueryGetData(const FormatEtc: TFormatEtc): HRESULT; StdCall;
var
   i : Integer;
begin

{   if(!lpFormat)
   begin
      return S_FALSE;
   end}

	//
	// Check the aspects we support.  Implementations of this object will only
	// support DVASPECT_CONTENT.
	//
	if (DVASPECT_CONTENT and FormatEtc.dwAspect) = 0 then
   begin
      Result := DV_E_DVASPECT;
      exit;
   end;

	//
	// Now check for an appropriate clipboard format and TYMED.
	//
   for i := 0 to m_cFormatsAvailable - 1 do
   begin
      if (FormatEtc.cfFormat = m_strFormatEtc[i].cfFormat) and
         ((FormatEtc.tymed and m_strFormatEtc[i].tymed) > 0) then
      begin
         Result := S_OK;
         exit;
      end;
   end;

   Result := DV_E_TYMED;
end;

  //******************* TDropSource.EnumFormatEtc *************************
function TDropSource.EnumFormatEtc(dwDirection: LongInt; out EnumFormatEtc:IEnumFormatEtc): HRESULT; StdCall;
begin
   if dwDirection = DATADIR_GET then
   begin
      EnumFormatEtc := TEnumFormatEtc.Create(@m_strFormatEtc, m_cFormatsAvailable, 0);
      Result := S_OK;
   end
   else
   begin
      Result := OLE_S_USEREG; // Should this be Not Implemented?
   end
end;


//////////////////////////////
//                          //
//                          //
// TEnumFormatEtc           //
//                          //
//                          //
//////////////////////////////

constructor TEnumFormatEtc.Create(FormatList: {array of TFormatEtc} 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
   begin
      pCeltFetched^ := i;
   end;
   if i = Celt then
   begin
      result := S_OK;
   end
   else
   begin
      result := S_FALSE;
   end;
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;

(* How to use:

      DragDrop := TDropSource.Create(self);
      DragDrop.fOnCreateFileGroup    := CreateFileGroupDescriptor;
      DragDrop.fOnCreateFileContents := CreateFileContents;
      DragDrop.Execute;
      DragDrop.Free;
*)

(* Sample callback functions.....

function TMainForm.CreateFileGroupDescriptor : HGLOBAL;
var
   nItems   : Integer;
   hg       : HGLOBAL;
   pfgd     : PFILEGROUPDESCRIPTOR;
   i        : integer;
   FileName : String;
begin
   nItems := 30;
//	OutputDebugString("Create group descriptor\n");


   hg := GlobalAlloc({GMEM_FIXED}GMEM_MOVEABLE , sizeof(FILEGROUPDESCRIPTOR) + (nItems - 1) * sizeof(FILEDESCRIPTOR));
   if hg <> 0 then
   begin
      pfgd := PFILEGROUPDESCRIPTOR(GlobalLock(hg));
      if Assigned(pfgd) then
      begin
         i := 0;

         pfgd.cItems := nItems;
//         TCHAR szName[MAX_PATH];

         // add a dir
	      pfgd.fgd[i].dwFlags := FD_ATTRIBUTES;
	      pfgd.fgd[i].dwFileAttributes := FILE_ATTRIBUTE_DIRECTORY;

//         wsprintf(szName, TEXT("mydir"), i);
//         lstrcpyn(pfgd->fgd[i].cFileName, szName, sizeof(pfgd->fgd[i].cFileName));
         FileName := 'mydir';
         StrLCopy(pfgd.fgd[i].cFileName, PChar(FileName), sizeof(pfgd.fgd[i].cFileName));

         // and 2 files
//         for(i = 1; i < nItems; i++)
         for i := 1 to nItems - 1 do
         begin
	         pfgd.fgd[i].dwFlags := FD_ATTRIBUTES;
	         pfgd.fgd[i].dwFileAttributes := FILE_ATTRIBUTE_NORMAL;

//            wsprintf(szName, TEXT("mydir\\myfile%d.txt"), i);
            FileName := 'myfile' + IntToStr(i) + '.txt';
            StrLCopy(pfgd.fgd[i].cFileName, PChar(FileName), sizeof(pfgd.fgd[i].cFileName));
         end;

         GlobalUnlock(hg);
      end;
   end;
   Result := hg;
end;

function TMainForm.CreateFileContents(nItem : Integer) : HGLOBAL;
var
   hg    : HGLOBAL;
   Text  : String;
   psz   : PChar;
   FileSize : DWORD;
begin
//   hg := 0;
//	OutputDebugString("Create file contents\n");
//   char     szText[MAX_PATH];

//   OutputDebugString("Extracting data from ex2fs partition...\n");

//   wsprintfA(szText, "This file is myfile%d.txt created from CFSTR_FILECONTENTS\r\n", nItem);
   Text := 'This is myfile' + IntToStr(nItem) + '.txt';
//   OutputDebugString(szText);

   FileSize := Length(Text) + 1;

   if nItem = 3 then
   begin
      FileSize := 2 * 1024 * 1024;
   end;
   hg := GlobalAlloc({GMEM_FIXED}GMEM_MOVEABLE , FileSize);

   if hg > 0 then
   begin
      psz := PChar(GlobalLock(hg));
      if Assigned(psz) then
      begin
//         lstrcpyA(psz, szText);
         StrCopy(psz, PChar(Text));

         GlobalUnlock(hg);
      end;
   end
   else
   begin
      MessageDlg('Error allocating memory!', mtError, [mbOK], 0);
   end;
   Result := hg;
end;

*)


initialization
  OleInitialize(nil);

finalization
  OleUninitialize;

end.
