unit DropPIDLSource;

// -----------------------------------------------------------------------------
// Project:         Drag and Drop Component Suite
// Component Names: TDropPIDLSource
// Module:          DropPIDLSource
// Description:     Implements Dragging & Dropping of PIDLs
//                  FROM your application to another.
// Version:         3.7
// Date:            22-JUL-1999
// Target:          Win32, Delphi 3 - Delphi 5, C++ Builder 3, C++ Builder 4
// Authors:         Angus Johnson,   ajohnson@rpi.net.au
//                  Anders Melander, anders@melander.dk
//                                   http://www.melander.dk
// Copyright        © 1997-99 Angus Johnson & Anders Melander
// -----------------------------------------------------------------------------

interface

uses
  DropSource,
  Classes, ActiveX, ShlObj;

{$include DragDrop.inc}

type
  TDropPIDLSource = class(TDropSource)
  private
    fPIDLs: TStrings; //NOTE: contains folder PIDL as well as file PIDLs
    fMappedNames: TStrings;
    function GetFilename(index: integer): string; //used internally
    procedure SetMappedNames(names: TStrings);
  protected
    function DoGetData(const FormatEtcIn: TFormatEtc;
      OUT Medium: TStgMedium):HRESULT; Override;
    function CutOrCopyToClipboard: boolean; Override;
  public
    constructor Create(aOwner: TComponent); Override;
    destructor Destroy; Override;
    procedure CopyFolderPidlToList(pidl: PItemIDList);
    procedure CopyFilePidlToList(pidl: PItemIDList);
    property MappedNames: TStrings read fMappedNames write SetMappedNames;
  end;

procedure Register;

//Exposed as also used by DropPIDLTarget...
function PidlToString(pidl: PItemIDList): String;
function JoinPidlStrings(pidl1,pidl2: string): String;

implementation

uses
  Windows, 
  SysUtils,
  ClipBrd;

procedure Register;
begin
  RegisterComponents('DragDrop', [TDropPIDLSource]);
end;

// -----------------------------------------------------------------------------
//			Miscellaneous Functions...
// -----------------------------------------------------------------------------

function GetSizeOfPidl(pidl: PItemIDList): integer;
var
  i: integer;
begin
  result := SizeOf(Word);
  repeat
    i := pSHItemID(pidl)^.cb;
    inc(result,i);
    inc(longint(pidl),i);
  until i = 0;
end;
// -----------------------------------------------------------------------------

function PidlToString(pidl: PItemIDList): String;
var
  PidlLength: integer;
begin
  PidlLength := GetSizeOfPidl(pidl);
  setlength(result,PidlLength);
  Move(pidl^,pchar(result)^,PidlLength);
end;
// -----------------------------------------------------------------------------

function JoinPidlStrings(pidl1,pidl2: string): String;
var
  PidlLength: integer;
begin
  if Length(pidl1) <= 2 then PidlLength := 0
  else PidlLength := Length(pidl1)-2;
  setlength(result,PidlLength+length(pidl2));
  if PidlLength > 0 then Move(pidl1[1],result[1],PidlLength);
  Move(pidl2[1],result[PidlLength+1],length(pidl2));
end;

// -----------------------------------------------------------------------------
//			TDropPIDLSource
// -----------------------------------------------------------------------------
 
constructor TDropPIDLSource.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  fPIDLs := TStringList.create;
  fMappedNames := TStringList.Create;
  AddFormatEtc(CF_HDROP, NIL, DVASPECT_CONTENT, -1, TYMED_HGLOBAL);
  AddFormatEtc(CF_IDLIST, NIL, DVASPECT_CONTENT, -1, TYMED_HGLOBAL);
  AddFormatEtc(CF_PREFERREDDROPEFFECT, NIL, DVASPECT_CONTENT, -1, TYMED_HGLOBAL);
  AddFormatEtc(CF_FILENAMEMAP, NIL, DVASPECT_CONTENT, -1, TYMED_HGLOBAL);
  AddFormatEtc(CF_FILENAMEMAPW, NIL, DVASPECT_CONTENT, -1, TYMED_HGLOBAL);
end;
// -----------------------------------------------------------------------------

destructor TDropPIDLSource.Destroy;
begin
  fPIDLs.free;
  fMappedNames.free;
  inherited Destroy;
end;
// -----------------------------------------------------------------------------

//this function is used internally by DoGetData()...
function TDropPIDLSource.GetFilename(index: integer): string;
var
  PidlStr: string;
  buff: array [0..MAX_PATH] of char;
begin
  if (index < 1) or (index >= fPIDLs.count) then result := ''
  else
  begin
    PidlStr := JoinPidlStrings(fPIDLs[0], fPIDLs[index]);
    SHGetPathFromIDList(PItemIDList(pChar(PidlStr)),buff);
    result := buff;
  end;
end;
// ----------------------------------------------------------------------------- 

//Note: Once the PIDL has been copied into the list it can be 'freed'.
procedure TDropPIDLSource.CopyFolderPidlToList(pidl: PItemIDList);
begin
  fPIDLs.clear;
  fMappedNames.clear;
  fPIDLs.add(PidlToString(pidl));
end;
// ----------------------------------------------------------------------------- 

//Note: Once the PIDL has been copied into the list it can be 'freed'.
procedure TDropPIDLSource.CopyFilePidlToList(pidl: PItemIDList);
begin
  if fPIDLs.count < 1 then exit; //no folder pidl has been added!
  fPIDLs.add(PidlToString(pidl));
end;
// ----------------------------------------------------------------------------- 

procedure TDropPIDLSource.SetMappedNames(names: TStrings);
begin
  fMappedNames.assign(names);
end;
// -----------------------------------------------------------------------------

function TDropPIDLSource.CutOrCopyToClipboard: boolean;
var
  FormatEtcIn: TFormatEtc;
  Medium: TStgMedium;
begin
  FormatEtcIn.cfFormat := CF_IDLIST;
  FormatEtcIn.dwAspect := DVASPECT_CONTENT;
  FormatEtcIn.tymed := TYMED_HGLOBAL;
  if (fPIDLs.count < 2) then result := false
  else if GetData(formatetcIn,Medium) = S_OK then
  begin
    Clipboard.SetAsHandle(CF_IDLIST,Medium.hGlobal);
    result := true;
  end else result := false;
end;
// ----------------------------------------------------------------------------- 

function TDropPIDLSource.DoGetData(const FormatEtcIn: TFormatEtc;
  OUT Medium: TStgMedium):HRESULT;
var
  i, MemSpace, CidaSize, Offset, StrLength: integer;
  pCIDA: PIDA;
  pInt: ^UINT;
  pOffset: PChar;
  DropEffect: ^DWORD;
  dropfiles: pDropFiles;
  fFiles: string;
  pFileList: PChar;
  pFileW: PWideChar;
begin
  Medium.tymed := 0;
  Medium.UnkForRelease := NIL;
  Medium.hGlobal := 0;
  if fPIDLs.count < 2 then result := E_UNEXPECTED
  //--------------------------------------------------------------------------
  else if (FormatEtcIn.cfFormat = CF_HDROP) and
    (FormatEtcIn.dwAspect = DVASPECT_CONTENT) and
    (FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) then
  begin
    fFiles := '';
    for i := 1 to fPIDLs.Count-1 do
      AppendStr(fFiles,GetFilename(i)+#0);
    AppendStr(fFiles,#0);

    Medium.hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT,
        SizeOf(TDropFiles)+length(fFiles));
    if (Medium.hGlobal = 0) then
      result:=E_OUTOFMEMORY
    else
    begin
      Medium.tymed := TYMED_HGLOBAL;
      dropfiles := GlobalLock(Medium.hGlobal);
      try
        dropfiles^.pfiles := SizeOf(TDropFiles);
        dropfiles^.fwide := False;
        longint(pFileList) := longint(dropfiles)+SizeOf(TDropFiles);
        move(fFiles[1],pFileList^,length(fFiles));
      finally
        GlobalUnlock(Medium.hGlobal);
      end;
      result := S_OK;
    end;
  end
  //--------------------------------------------------------------------------
  else if (FormatEtcIn.cfFormat = CF_FILENAMEMAP) and
    (FormatEtcIn.dwAspect = DVASPECT_CONTENT) and
    (FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) and
    //make sure there is a Mapped Name for each filename...
    (fMappedNames.Count = fPidls.Count-1) then
  begin
    strlength := 0;
    for i := 0 to fMappedNames.Count-1 do
      Inc(strlength, Length(fMappedNames[i])+1);

    Medium.hGlobal :=
      GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, strlength+1);
    if (Medium.hGlobal = 0) then
      result:=E_OUTOFMEMORY
    else
    begin
      Medium.tymed := TYMED_HGLOBAL;
      pFileList := GlobalLock(Medium.hGlobal);
      try
        for i := 0 to fMappedNames.Count-1 do
        begin
          StrPCopy(pFileList,fMappedNames[i]);
          Inc(pFileList, Length(fMappedNames[i])+1);
        end;
        pFileList^ := #0;
      finally
        GlobalUnlock(Medium.hGlobal);
      end;
      result := S_OK;
    end;
  end
  //--------------------------------------------------------------------------
  else if (FormatEtcIn.cfFormat = CF_FILENAMEMAPW) and
    (FormatEtcIn.dwAspect = DVASPECT_CONTENT) and
    (FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) and
    //make sure there is a Mapped Name for each filename...
    (fMappedNames.Count = fPidls.Count-1) then
  begin
    strlength := 2;
    for i := 0 to fMappedNames.Count-1 do
      Inc(strlength, (Length(fMappedNames[i])+1)*2);

    Medium.hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, strlength);
    if (Medium.hGlobal = 0) then
      result:=E_OUTOFMEMORY
    else
    begin
      Medium.tymed := TYMED_HGLOBAL;
      pFileW := GlobalLock(Medium.hGlobal);
      try
        for i := 0 to fMappedNames.Count-1 do
        begin
          StringToWideChar(fMappedNames[i],
              pFileW, (length(fMappedNames[i])+1)*2);
          Inc(pFileW, Length(fMappedNames[i])+1);
        end;
      pFileW^ := #0;
      finally
        GlobalUnlock(Medium.hGlobal);
      end;
      result := S_OK;
    end;
  end
  //--------------------------------------------------------------------------
  else if (FormatEtcIn.cfFormat = CF_IDLIST) and
    (FormatEtcIn.dwAspect = DVASPECT_CONTENT) and
    (FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) then
  begin
    CidaSize := sizeof(UINT)*(1+fPIDLs.Count); //size of CIDA structure
    MemSpace := CidaSize;
    for i := 0 to fPIDLs.Count-1 do
      Inc(MemSpace, Length(fPIDLs[i]));
    Medium.hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, MemSpace);

    if (Medium.hGlobal = 0) then
      result := E_OUTOFMEMORY
    else
    begin
      medium.tymed := TYMED_HGLOBAL;
      pCIDA := PIDA(GlobalLock(Medium.hGlobal));
      try
        pCIDA^.cidl := fPIDLs.count-1; //don't count folder
        pInt := @(pCIDA^.aoffset); //points to aoffset[0];
        pOffset := pChar(pCIDA);
        //move pOffset to point to the Folder PIDL location
        inc(pOffset,CidaSize);
        offset := CidaSize;
        for i := 0 to fPIDLs.Count-1 do
        begin
          pInt^ := offset; //store 'offset' into aoffset[i]
          //copy the PIDL into pOffset
          Move(pointer(fPIDLs[i])^,pOffset^,length(fPIDLs[i]));
          //increase 'offset' by the size of the last pidl
          inc(offset,length(fPIDLs[i]));
          inc(pInt); //increment the aoffset pointer
          //move pOffset ready for the next PIDL
          inc(pOffset,length(fPIDLs[i]));
        end;
      finally
        GlobalUnlock(Medium.hGlobal);
      end;
     result := S_OK;
    end;
  end
  //--------------------------------------------------------------------------
  else if (FormatEtcIn.cfFormat = CF_PREFERREDDROPEFFECT) and
    (FormatEtcIn.dwAspect = DVASPECT_CONTENT) and
    (FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) then
  begin
    Medium.tymed := TYMED_HGLOBAL;
    Medium.hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, SizeOf(DWORD));
    if Medium.hGlobal = 0 then
      result:=E_OUTOFMEMORY
    else
    begin
      DropEffect := GlobalLock(Medium.hGlobal);
      try
        DropEffect^ := DWORD(FeedbackEffect);
      finally
        GlobalUnLock(Medium.hGlobal);
      end;
      result := S_OK;
    end;
  end
  //--------------------------------------------------------------------------
  else
    result := DV_E_FORMATETC;
end;
// -----------------------------------------------------------------------------
// -----------------------------------------------------------------------------

end.
