RealICQClient/Includes/DRAGDROP/Components/DragDropPIDL.pas

unit DragDropPIDL;

// -----------------------------------------------------------------------------
// Project:         Drag and Drop Component Suite
// Module:          DragDropPIDL
// Description:     Implements Dragging & Dropping of PIDLs (files and folders).
// Version:         4.0
// Date:            18-MAY-2001
// Target:          Win32, Delphi 5-6
// Authors:         Anders Melander, anders@melander.dk, http://www.melander.dk
// Copyright        © 1997-2001 Angus Johnson & Anders Melander
// -----------------------------------------------------------------------------

interface

uses
  DragDrop,
  DropTarget,
  DropSource,
  DragDropFormats,
  DragDropFile,
  Windows,
  ActiveX,
  Classes,
  ShlObj;

{$include DragDrop.inc}

type
////////////////////////////////////////////////////////////////////////////////
//
//		TPIDLClipboardFormat
//
////////////////////////////////////////////////////////////////////////////////
// Supports the 'Shell IDList Array' format.
////////////////////////////////////////////////////////////////////////////////
  TPIDLClipboardFormat = class(TCustomSimpleClipboardFormat)
  private
    FPIDLs: TStrings; // Used internally to store PIDLs. We use strings to simplify cleanup.
    FFilenames: TStrings;
  protected
    function ReadData(Value: pointer; Size: integer): boolean; override;
    function WriteData(Value: pointer; Size: integer): boolean; override;
    function GetSize: integer; override;
  public
    constructor Create; override;
    destructor Destroy; override;
    function GetClipboardFormat: TClipFormat; override;
    procedure Clear; override;
    function HasData: boolean; override;
    property PIDLs: TStrings read FPIDLs;
    property Filenames: TStrings read FFilenames;
  end;


type
////////////////////////////////////////////////////////////////////////////////
//
//		TPIDLDataFormat
//
////////////////////////////////////////////////////////////////////////////////
  TPIDLDataFormat = class(TCustomDataFormat)
  private
    FPIDLs		: TStrings;
    FFilenames		: TStrings;
  protected
  public
    constructor Create(AOwner: TDragDropComponent); override;
    destructor Destroy; override;
    function Assign(Source: TClipboardFormat): boolean; override;
    function AssignTo(Dest: TClipboardFormat): boolean; override;
    procedure Clear; override;
    function HasData: boolean; override;
    function NeedsData: boolean; override;
    property PIDLs: TStrings read FPIDLs;
    property Filenames: TStrings read FFilenames;
  end;


type
////////////////////////////////////////////////////////////////////////////////
//
//		TDropPIDLTarget
//
////////////////////////////////////////////////////////////////////////////////
  TDropPIDLTarget = class(TCustomDropMultiTarget)
  private
    FPIDLDataFormat	: TPIDLDataFormat;
    FFileMapDataFormat	: TFileMapDataFormat;
    function GetFilenames: TStrings;
  protected
    function GetPIDLs: TStrings;
    function GetPIDLCount: integer;
    function GetMappedNames: TStrings;
    property PIDLs: TStrings read GetPIDLs;
    function DoGetPIDL(Index: integer): pItemIdList;
    function GetPreferredDropEffect: LongInt; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; Override;

    // Note: It is the callers responsibility to cleanup
    // the returned PIDLs from the following 3 methods:
    // - GetFolderPidl
    // - GetRelativeFilePidl
    // - GetAbsoluteFilePidl
    // Use the CoTaskMemFree procedure to free the PIDLs.
    function GetFolderPIDL: pItemIdList;
    function GetRelativeFilePIDL(Index: integer): pItemIdList;
    function GetAbsoluteFilePIDL(Index: integer): pItemIdList;
    property PIDLCount: integer read GetPIDLCount; // Includes folder pidl in count

    // If you just want the filenames (not PIDLs) then use ...
    property Filenames: TStrings read GetFilenames;
    // MappedNames is only needed if files need to be renamed after a drag or
    // e.g. dragging from 'Recycle Bin'.
    property MappedNames: TStrings read GetMappedNames;
  end;

////////////////////////////////////////////////////////////////////////////////
//
//		TDropPIDLSource
//
////////////////////////////////////////////////////////////////////////////////
  TDropPIDLSource = class(TCustomDropMultiSource)
  private
    FPIDLDataFormat	: TPIDLDataFormat;
    FFileMapDataFormat	: TFileMapDataFormat;
  protected
    function GetMappedNames: TStrings;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure CopyFolderPIDLToList(pidl: PItemIDList);
    procedure CopyFilePIDLToList(pidl: PItemIDList);
    property MappedNames: TStrings read GetMappedNames;
  end;


////////////////////////////////////////////////////////////////////////////////
//
//		PIDL utility functions
//
////////////////////////////////////////////////////////////////////////////////

//: GetPIDLsFromData extracts a PIDL list from a memory block and stores the
// PIDLs in a string list.
function GetPIDLsFromData(Data: pointer; Size: integer; PIDLs: TStrings): boolean;

//: GetPIDLsFromHGlobal extracts a PIDL list from a global memory block and
// stores the PIDLs in a string list.
function GetPIDLsFromHGlobal(const HGlob: HGlobal; PIDLs: TStrings): boolean;

//: GetPIDLsFromFilenames converts a list of files to PIDLs and stores the
// PIDLs in a string list. All the PIDLs are relative to a common root.
function GetPIDLsFromFilenames(const Files: TStrings; PIDLs: TStrings): boolean;

//: GetRootFolderPIDL finds the PIDL of the folder which is the parent of a list
// of files. The PIDl is returned as a string. If the files do not share a
// common root, an empty string is returnde.
function GetRootFolderPIDL(const Files: TStrings): string;

//: GetFullPIDLFromPath converts a path (filename and path) to a folder/filename
// PIDL pair.
function GetFullPIDLFromPath(Path: string): pItemIDList;

//: GetFullPathFromPIDL converts a folder/filename PIDL pair to a full path.
function GetFullPathFromPIDL(PIDL: pItemIDList): string;

//: PIDLToString converts a single PIDL to a string.
function PIDLToString(pidl: PItemIDList): string;

//: StringToPIDL converts a PIDL string to a PIDL.
function StringToPIDL(const PIDL: string): PItemIDList;

//: JoinPIDLStrings merges two PIDL strings into one.
function JoinPIDLStrings(pidl1, pidl2: string): string;

//: ConvertFilesToShellIDList converts a list of files to a PIDL list. The
// files are relative to the folder specified by the Path parameter. The PIDLs
// are returned as a global memory handle.
function ConvertFilesToShellIDList(Path: string; Files: TStrings): HGlobal;

//: GetSizeOfPIDL calculates the size of a PIDL list.
function GetSizeOfPIDL(PIDL: pItemIDList): integer;

//: CopyPIDL makes a copy of a PIDL.
// It is the callers responsibility to free the returned PIDL.               
function CopyPIDL(PIDL: pItemIDList): pItemIDList;

{$ifndef BCB}
// Undocumented PIDL utility functions...
// From http://www.geocities.com/SiliconValley/4942/
function ILCombine(pidl1,pidl2:PItemIDList): PItemIDList; stdcall;
function ILFindLastID(pidl: PItemIDList): PItemIDList; stdcall;
function ILClone(pidl: PItemIDList): PItemIDList; stdcall;
function ILRemoveLastID(pidl: PItemIDList): LongBool; stdcall;
function ILIsEqual(pidl1,pidl2: PItemIDList): LongBool; stdcall;
procedure ILFree(Buffer: PItemIDList); stdcall;

// Undocumented IMalloc utility functions...
function SHAlloc(BufferSize: ULONG): Pointer; stdcall;
procedure SHFree(Buffer: Pointer); stdcall;
{$endif}

////////////////////////////////////////////////////////////////////////////////
//
//		PIDL/IShellFolder utility functions
//
////////////////////////////////////////////////////////////////////////////////

//: GetShellFolderOfPath retrieves an IShellFolder interface which can be used
// to manage the specified folder.
function GetShellFolderOfPath(FolderPath: string): IShellFolder;

//: GetPIDLDisplayName retrieves the display name of the specified PIDL,
// relative to the specified folder.
function GetPIDLDisplayName(Folder: IShellFolder; PIDL: PItemIdList): string;

//: GetSubPIDL retrieves the PIDL of the specified file or folder to a PIDL.
// The PIDL is relative to the folder specified by the Folder parameter.
function GetSubPIDL(Folder: IShellFolder; Sub: string): pItemIDList;


////////////////////////////////////////////////////////////////////////////////
//
//		Component registration
//
////////////////////////////////////////////////////////////////////////////////
procedure Register;

implementation

uses
  ShellAPI,
  SysUtils;

resourcestring
  sNoFolderPIDL = 'Folder PIDL must be added first';

////////////////////////////////////////////////////////////////////////////////
//
//		Component registration
//
////////////////////////////////////////////////////////////////////////////////
procedure Register;
begin
  RegisterComponents(DragDropComponentPalettePage, [TDropPIDLTarget,
    TDropPIDLSource]);
end;


////////////////////////////////////////////////////////////////////////////////
//
//		PIDL utility functions
//
////////////////////////////////////////////////////////////////////////////////
function GetPIDLsFromData(Data: pointer; Size: integer; PIDLs: TStrings): boolean;
var
  i			: integer;
  pOffset		: ^UINT;
  PIDL			: PItemIDList;
begin
  PIDLs.Clear;

  Result := (Data <> nil) and
    (Size >= integer(PIDA(Data)^.cidl) * (SizeOf(UINT)+SizeOf(PItemIDList)) + SizeOf(UINT));
  if (not Result) then
    exit;

  pOffset := @(PIDA(Data)^.aoffset[0]);
  i := PIDA(Data)^.cidl; // Note: Count doesn't include folder PIDL
  while (i >= 0) do
  begin
    PIDL := PItemIDList(UINT(Data)+ pOffset^);
    PIDLs.Add(PIDLToString(PIDL));
    inc(pOffset);
    dec(i);
  end;
  Result := (PIDLs.Count > 1);
end;

function GetPIDLsFromHGlobal(const HGlob: HGlobal; PIDLs: TStrings): boolean;
var
  pCIDA			: PIDA;
begin
  pCIDA := PIDA(GlobalLock(HGlob));
  try
    Result := GetPIDLsFromData(pCIDA, GlobalSize(HGlob), PIDLs);
  finally
    GlobalUnlock(HGlob);
  end;
end;

resourcestring
  sBadDesktop = 'Failed to get interface to Desktop';
  sBadFilename = 'Invalid filename: %s';

(*
** Find the folder which is the parent of all the files in a list.
*)
function GetRootFolderPIDL(const Files: TStrings): string;
var
  DeskTopFolder: IShellFolder;
  WidePath: WideString;
  PIDL: pItemIDList;
  PIDLs: TStrings;
  s: string;
  PIDL1, PIDL2: pItemIDList;
  Size, MaxSize: integer;
  i: integer;
begin
  Result := '';
  if (Files.Count = 0) then
    exit;

  if (SHGetDesktopFolder(DeskTopFolder) <> NOERROR) then
    raise Exception.Create(sBadDesktop);

  PIDLs := TStringList.Create;
  try
    // First convert all paths to PIDLs.
    for i := 0 to Files.Count-1 do
    begin
      WidePath := ExtractFilePath(Files[i]);
      if (DesktopFolder.ParseDisplayName(0, nil, PWideChar(WidePath), PULONG(nil)^,
        PIDL, PULONG(nil)^) <> NOERROR) then
        raise Exception.Create(sBadFilename);
      try
        PIDLs.Add(PIDLToString(PIDL));
      finally
        coTaskMemFree(PIDL);
      end;
    end;

    Result := PIDLs[0];
    MaxSize := Length(Result)-SizeOf(Word);
    PIDL := pItemIDList(PChar(Result));
    for i := 1 to PIDLs.Count-1 do
    begin
      s := PIDLs[1];
      PIDL1 := PIDL;
      PIDL2 := pItemIDList(PChar(s));
      Size := 0;
      while (Size < MaxSize) and (PIDL1^.mkid.cb <> 0) and (PIDL1^.mkid.cb = PIDL2^.mkid.cb) and (CompareMem(PIDL1, PIDL2, PIDL1^.mkid.cb)) do
      begin
        inc(Size, PIDL1^.mkid.cb);
        inc(integer(PIDL2), PIDL1^.mkid.cb);
        inc(integer(PIDL1), PIDL1^.mkid.cb);
      end;
      if (Size <> MaxSize) then
      begin
        MaxSize := Size;
        SetLength(Result, Size+SizeOf(Word));
        PIDL1^.mkid.cb := 0;
      end;
      if (Size = 0) then
        break;
    end;
  finally
    PIDLs.Free;
  end;
end;

function GetPIDLsFromFilenames(const Files: TStrings; PIDLs: TStrings): boolean;
var
  RootPIDL: string;
  i: integer;
  PIDL: pItemIdList;
  FilePIDL: string;
begin
  Result := False;
  PIDLs.Clear;
  if (Files.Count = 0) then
    exit;

  // Get the PIDL of the root folder...
  // All the file PIDLs will be relative to this PIDL
  RootPIDL := GetRootFolderPIDL(Files);
  if (RootPIDL = '') then
    exit;

  Result := True;

  PIDLS.Add(RootPIDL);
  // Add the file PIDLs (all relative to the root)...
  for i := 0 to Files.Count-1 do
  begin
    PIDL := GetFullPIDLFromPath(Files[i]);
    if (PIDL = nil) then
    begin
      Result := False;
      PIDLs.Clear;
      break;
    end;
    try
      FilePIDL := PIDLToString(PIDL);
    finally
      coTaskMemFree(PIDL);
    end;
    // Remove the root PIDL from the file PIDL making it relative to the root.
    PIDLS.Add(copy(FilePIDL, Length(RootPIDL)-SizeOf(Word)+1,
      Length(FilePIDL)-(Length(RootPIDL)-SizeOf(Word))));
  end;
end;

function GetSizeOfPIDL(PIDL: pItemIDList): integer;
var
  Size: integer;
begin
  if (PIDL <> nil) then
  begin
    Result := SizeOf(PIDL^.mkid.cb);
    repeat
      Size := PIDL^.mkid.cb;
      inc(Result, Size);
      inc(integer(PIDL), Size);
    until (Size = 0);
  end else
    Result := 0;
end;

function CopyPIDL(PIDL: pItemIDList): pItemIDList;
var
  Size: integer;
begin
  Size := GetSizeOfPIDL(PIDL);
  if (Size > 0) then
  begin
    Result := ShellMalloc.Alloc(Size);
    if (Result <> nil) then
      Move(PIDL^, Result^, Size);
  end else
    Result := nil;
end;

function GetFullPIDLFromPath(Path: string): pItemIDList;
var
  DeskTopFolder		: IShellFolder;
  WidePath		: WideString;
begin
  WidePath := Path;
  if (SHGetDesktopFolder(DeskTopFolder) = NOERROR) then
  begin
    if (DesktopFolder.ParseDisplayName(0, nil, PWideChar(WidePath), PULONG(nil)^,
      Result, PULONG(nil)^) <> NOERROR) then
      Result := nil;
  end else
    Result := nil;
end;

function GetFullPathFromPIDL(PIDL: pItemIDList): string;
var
  Path: array[0..MAX_PATH] of char;
begin
  if SHGetPathFromIDList(PIDL, Path) then
    Result := Path
  else
    Result := '';
end;

// See "Clipboard Formats for Shell Data Transfers" in Ole.hlp...
// (Needed to drag links (shortcuts).)
type
  POffsets = ^TOffsets;
  TOffsets = array[0..$FFFF] of UINT;

function ConvertFilesToShellIDList(Path: string; Files: TStrings): HGlobal;
var
  shf: IShellFolder;
  PathPidl, pidl: pItemIDList;
  Ida: PIDA;
  pOffset: POffsets;
  ptrByte: ^Byte;
  i, PathPidlSize, IdaSize, PreviousPidlSize: integer;
begin
  Result := 0;
  shf := GetShellFolderOfPath(path);
  if shf = nil then
    exit;
  // Calculate size of IDA structure ...
  // cidl: UINT ; Directory pidl
  // offset: UINT ; all file pidl offsets
  IdaSize := (Files.Count + 2) * SizeOf(UINT);

  PathPidl := GetFullPIDLFromPath(path);
  if PathPidl = nil then
    exit;
  try
    PathPidlSize := GetSizeOfPidl(PathPidl);

    //Add to IdaSize space for ALL pidls...
    IdaSize := IdaSize + PathPidlSize;
    for i := 0 to Files.Count-1 do
    begin
      pidl := GetSubPidl(shf, files[i]);
      try
        IdaSize := IdaSize + GetSizeOfPidl(Pidl);
      finally
        ShellMalloc.Free(pidl);
      end;
    end;

    //Allocate memory...
    Result := GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, IdaSize);
    if (Result = 0) then
      exit;
    try
      Ida := GlobalLock(Result);
      try
        FillChar(Ida^, IdaSize, 0);

        //Fill in offset and pidl data...
        Ida^.cidl := Files.Count; //cidl = file count
        pOffset := POffsets(@(Ida^.aoffset));
        pOffset^[0] := (Files.Count+2) * sizeof(UINT); //offset of Path pidl

        ptrByte := pointer(Ida);
        inc(ptrByte, pOffset^[0]); //ptrByte now points to Path pidl
        Move(PathPidl^, ptrByte^, PathPidlSize); //copy path pidl

        PreviousPidlSize := PathPidlSize;
        for i := 1 to Files.Count do
        begin
          pidl := GetSubPidl(shf,files[i-1]);
          try
            pOffset^[i] := pOffset^[i-1] + UINT(PreviousPidlSize); //offset of pidl
            PreviousPidlSize := GetSizeOfPidl(Pidl);

            ptrByte := pointer(Ida);
            inc(ptrByte, pOffset^[i]); //ptrByte now points to current file pidl
            Move(Pidl^, ptrByte^, PreviousPidlSize); //copy file pidl
                                  //PreviousPidlSize = current pidl size here
          finally
            ShellMalloc.Free(pidl);
          end;
        end;
      finally
        GlobalUnLock(Result);
      end;
    except
      GlobalFree(Result);
      raise;
    end;
  finally
    ShellMalloc.Free(PathPidl);
  end;
end;

function PIDLToString(pidl: PItemIDList): String;
var
  PidlLength		: integer;
begin
  PidlLength := GetSizeOfPidl(pidl);
  SetLength(Result, PidlLength);
  Move(pidl^, PChar(Result)^, PidlLength);
end;

function StringToPIDL(const PIDL: string): PItemIDList;
begin
  Result := ShellMalloc.Alloc(Length(PIDL));
  if (Result <> nil) then
    Move(PChar(PIDL)^, Result^, Length(PIDL));
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(PChar(pidl1)^, PChar(Result)^, PidlLength);
  Move(PChar(pidl2)^, Result[PidlLength+1], Length(pidl2));
end;

{$ifndef BCB}
// BCB appearantly doesn't support ordinal DLL imports. Strange!
function ILCombine(pidl1,pidl2:PItemIDList): PItemIDList; stdcall;
  external shell32 index 25;
function ILFindLastID(pidl: PItemIDList): PItemIDList; stdcall;
  external shell32 index 16;
function ILClone(pidl: PItemIDList): PItemIDList; stdcall;
  external shell32 index 18;
function ILRemoveLastID(pidl: PItemIDList): LongBool; stdcall;
  external shell32 index 17;
function ILIsEqual(pidl1,pidl2: PItemIDList): LongBool; stdcall;
  external shell32 index 21;
procedure ILFree(Buffer: PItemIDList); stdcall;
  external shell32 index 155;

function SHAlloc(BufferSize: ULONG): Pointer; stdcall;
  external shell32 index 196;
procedure SHFree(Buffer: Pointer); stdcall;
  external shell32 index 195;
{$endif}

////////////////////////////////////////////////////////////////////////////////
//
//		PIDL/IShellFolder utility functions
//
////////////////////////////////////////////////////////////////////////////////
function GetShellFolderOfPath(FolderPath: string): IShellFolder;
var
  DeskTopFolder: IShellFolder;
  PathPidl: pItemIDList;
  WidePath: WideString;
  pdwAttributes: ULONG;
begin
  Result := nil;
  WidePath := FolderPath;
  pdwAttributes := SFGAO_FOLDER;
  if (SHGetDesktopFolder(DeskTopFolder) <> NOERROR) then
    exit;
  if (DesktopFolder.ParseDisplayName(0, nil, PWideChar(WidePath), PULONG(nil)^,
    PathPidl, pdwAttributes) = NOERROR) then
    try
      if (pdwAttributes and SFGAO_FOLDER <> 0) then
        DesktopFolder.BindToObject(PathPidl, nil, IID_IShellFolder,
          // Note: For Delphi 4 and prior, the ppvOut parameter must be a pointer.
          pointer(Result));
    finally
      ShellMalloc.Free(PathPidl);
    end;
end;

function GetSubPIDL(Folder: IShellFolder; Sub: string): pItemIDList;
var
  WidePath: WideString;
begin
  WidePath := Sub;
  Folder.ParseDisplayName(0, nil, PWideChar(WidePath), PULONG(nil)^, Result,
    PULONG(nil)^);
end;

function GetPIDLDisplayName(Folder: IShellFolder; PIDL: PItemIdList): string;
var
  StrRet: TStrRet;
begin
  Result := '';
  Folder.GetDisplayNameOf(PIDL, 0, StrRet);
  case StrRet.uType of
    STRRET_WSTR: Result := WideCharToString(StrRet.pOleStr);
    STRRET_OFFSET: Result := PChar(UINT(PIDL)+StrRet.uOffset);
    STRRET_CSTR: Result := StrRet.cStr;
  end;
end;


////////////////////////////////////////////////////////////////////////////////
//
//		TPIDLsToFilenamesStrings
//
////////////////////////////////////////////////////////////////////////////////
// Used internally to convert PIDLs to filenames on-demand.
////////////////////////////////////////////////////////////////////////////////
type
  TPIDLsToFilenamesStrings = class(TStrings)
  private
    FPIDLs: TStrings;
  protected
    function Get(Index: Integer): string; override;
    function GetCount: Integer; override;
    procedure Put(Index: Integer; const S: string); override;
    procedure PutObject(Index: Integer; AObject: TObject); override;
  public
    constructor Create(APIDLs: TStrings);
    procedure Clear; override;
    procedure Delete(Index: Integer); override;
    procedure Insert(Index: Integer; const S: string); override;
    procedure Assign(Source: TPersistent); override;
  end;

constructor TPIDLsToFilenamesStrings.Create(APIDLs: TStrings);
begin
  inherited Create;
  FPIDLs := APIDLs;
end;

function TPIDLsToFilenamesStrings.Get(Index: Integer): string;
var
  PIDL: string;
  Path: array [0..MAX_PATH] of char;
begin
  if (Index < 0) or (Index > FPIDLs.Count-2) then
    raise Exception.create('Filename index out of range');
  PIDL := JoinPIDLStrings(FPIDLs[0], FPIDLs[Index+1]);
  if SHGetPathFromIDList(PItemIDList(PChar(PIDL)), Path) then
    Result := Path
  else
    Result := '';
end;

function TPIDLsToFilenamesStrings.GetCount: Integer;
begin
  if FPIDLs.Count < 2 then
    Result := 0
  else
    Result := FPIDLs.Count-1;
end;

procedure TPIDLsToFilenamesStrings.Assign(Source: TPersistent);
begin
  if Source is TStrings then
  begin
    BeginUpdate;
    try
      GetPIDLsFromFilenames(TStrings(Source), FPIDLs);
    finally
      EndUpdate;
    end;
  end else
    inherited Assign(Source);
end;

// Inherited abstract methods which do not need implementation...
procedure TPIDLsToFilenamesStrings.Put(Index: Integer; const S: string);
begin
end;

procedure TPIDLsToFilenamesStrings.PutObject(Index: Integer; AObject: TObject);
begin
end;

procedure TPIDLsToFilenamesStrings.Clear;
begin
end;

procedure TPIDLsToFilenamesStrings.Delete(Index: Integer);
begin
end;

procedure TPIDLsToFilenamesStrings.Insert(Index: Integer; const S: string);
begin
end;

////////////////////////////////////////////////////////////////////////////////
//
//		TPIDLClipboardFormat
//
////////////////////////////////////////////////////////////////////////////////
constructor TPIDLClipboardFormat.Create;
begin
  inherited Create;
  FPIDLs := TStringList.Create;
  FFilenames := TPIDLsToFilenamesStrings.Create(FPIDLs);
end;

destructor TPIDLClipboardFormat.Destroy;
begin
  FFilenames.Free;
  FPIDLs.Free;
  inherited Destroy;
end;

var
  CF_IDLIST: TClipFormat = 0;

function TPIDLClipboardFormat.GetClipboardFormat: TClipFormat;
begin
  if (CF_IDLIST = 0) then
    CF_IDLIST := RegisterClipboardFormat(CFSTR_SHELLIDLIST);
  Result := CF_IDLIST;
end;

procedure TPIDLClipboardFormat.Clear;
begin
  FPIDLs.Clear;
end;

function TPIDLClipboardFormat.HasData: boolean;
begin
  Result := (FPIDLs.Count > 0);
end;

function TPIDLClipboardFormat.GetSize: integer;
var
  i			: integer;
begin
  Result := (FPIDLs.Count+1) * SizeOf(UINT);
  for i := 0 to FPIDLs.Count-1 do
    inc(Result, Length(FPIDLs[i]));
end;

function TPIDLClipboardFormat.ReadData(Value: pointer;
  Size: integer): boolean;
begin
  Result := GetPIDLsFromData(Value, Size, FPIDLs);
end;

function TPIDLClipboardFormat.WriteData(Value: pointer;
  Size: integer): boolean;
var
  i			: integer;
  pCIDA			: PIDA;
  Offset		: integer;
  pOffset		: ^UINT;
  PIDL			: PItemIDList;
begin
  pCIDA := PIDA(Value);
  pCIDA^.cidl := FPIDLs.Count-1; // Don't count folder PIDL
  pOffset := @(pCIDA^.aoffset[0]); // Points to aoffset[0]
  Offset := (FPIDLs.Count+1)*SizeOf(UINT); // Size of CIDA structure
  PIDL := PItemIDList(integer(pCIDA) + Offset); // PIDLs are stored after CIDA structure.

  for i := 0 to FPIDLs.Count-1 do
  begin
    pOffset^ := Offset; // Store relative offset of PIDL into aoffset[i]
    // Copy the PIDL
    Move(PChar(FPIDLs[i])^, PIDL^, length(FPIDLs[i]));
    // Move on to next PIDL
    inc(Offset, length(FPIDLs[i]));
    inc(pOffset);
    inc(integer(PIDL), length(FPIDLs[i]));
  end;

  Result := True;
end;


////////////////////////////////////////////////////////////////////////////////
//
//		TPIDLDataFormat
//
////////////////////////////////////////////////////////////////////////////////
constructor TPIDLDataFormat.Create(AOwner: TDragDropComponent);
begin
  inherited Create(AOwner);
  FPIDLs := TStringList.Create;
  TStringList(FPIDLs).OnChanging := DoOnChanging;
  FFilenames := TPIDLsToFilenamesStrings.Create(FPIDLs);
end;

destructor TPIDLDataFormat.Destroy;
begin
  FFilenames.Free;
  FPIDLs.Free;
  inherited Destroy;
end;

function TPIDLDataFormat.Assign(Source: TClipboardFormat): boolean;
begin
  Result := True;

  if (Source is TPIDLClipboardFormat) then
    FPIDLs.Assign(TPIDLClipboardFormat(Source).PIDLs)

  else if (Source is TFileClipboardFormat) then
    Result := GetPIDLsFromFilenames(TFileClipboardFormat(Source).Files, FPIDLs)

  else
    Result := inherited Assign(Source);
end;

function TPIDLDataFormat.AssignTo(Dest: TClipboardFormat): boolean;
begin
  Result := True;

  if (Dest is TPIDLClipboardFormat) then
    TPIDLClipboardFormat(Dest).PIDLs.Assign(FPIDLs)

  else if (Dest is TFileClipboardFormat) then
    TFileClipboardFormat(Dest).Files.Assign(Filenames)

  else
    Result := inherited Assign(Dest);
end;

procedure TPIDLDataFormat.Clear;
begin
  FPIDLs.Clear;
end;

function TPIDLDataFormat.HasData: boolean;
begin
  Result := (FPIDLs.Count > 0);
end;

function TPIDLDataFormat.NeedsData: boolean;
begin
  Result := (FPIDLs.Count = 0);
end;


////////////////////////////////////////////////////////////////////////////////
//
//		TDropPIDLTarget
//
////////////////////////////////////////////////////////////////////////////////
constructor TDropPIDLTarget.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FPIDLDataFormat := TPIDLDataFormat.Create(Self);
  FFileMapDataFormat := TFileMapDataFormat.Create(Self);
end;

destructor TDropPIDLTarget.Destroy;
begin
  FPIDLDataFormat.Free;
  FFileMapDataFormat.Free;
  inherited Destroy;
end;

function TDropPIDLTarget.GetPIDLs: TStrings;
begin
  Result := FPIDLDataFormat.PIDLs;
end;

function TDropPIDLTarget.DoGetPIDL(Index: integer): pItemIdList;
var
  PIDL			: string;
begin
  PIDL := PIDLs[Index];
  Result := ShellMalloc.Alloc(Length(PIDL));
  if (Result <> nil) then
    Move(PChar(PIDL)^, Result^, Length(PIDL));
end;

function TDropPIDLTarget.GetFolderPidl: pItemIdList;
begin
  Result := DoGetPIDL(0);
end;

function TDropPIDLTarget.GetRelativeFilePidl(Index: integer): pItemIdList;
begin
  Result := nil;
  if (index < 1) then
    exit;
  Result := DoGetPIDL(Index);
end;

function TDropPIDLTarget.GetAbsoluteFilePidl(Index: integer): pItemIdList;
var
  PIDL			: string;
begin
  Result := nil;
  if (index < 1) then
    exit;
  PIDL := JoinPIDLStrings(PIDLs[0], PIDLs[Index]);
  Result := ShellMalloc.Alloc(Length(PIDL));
  if (Result <> nil) then
    Move(PChar(PIDL)^, Result^, Length(PIDL));
end;

function TDropPIDLTarget.GetPIDLCount: integer;
begin
   // Note: Includes folder PIDL in count!
  Result := FPIDLDataFormat.PIDLs.Count;
end;

function TDropPIDLTarget.GetFilenames: TStrings;
begin
  Result := FPIDLDataFormat.Filenames;
end;

function TDropPIDLTarget.GetMappedNames: TStrings;
begin
  Result := FFileMapDataFormat.FileMaps;
end;

function TDropPIDLTarget.GetPreferredDropEffect: LongInt;
begin
  Result := inherited GetPreferredDropEffect;
  if (Result = DROPEFFECT_NONE) then
    Result := DROPEFFECT_COPY;
end;

////////////////////////////////////////////////////////////////////////////////
//
//		TDropPIDLSource
//
////////////////////////////////////////////////////////////////////////////////
constructor TDropPIDLSource.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FPIDLDataFormat := TPIDLDataFormat.Create(Self);
  FFileMapDataFormat := TFileMapDataFormat.Create(Self);
end;

destructor TDropPIDLSource.Destroy;
begin
  FPIDLDataFormat.Free;
  FFileMapDataFormat.Free;
  inherited Destroy;
end;

procedure TDropPIDLSource.CopyFolderPIDLToList(pidl: PItemIDList);
begin
  //Note: Once the PIDL has been copied into the list it can be 'freed'.
  FPIDLDataFormat.Clear;
  FFileMapDataFormat.Clear;
  FPIDLDataFormat.PIDLs.Add(PIDLToString(pidl));
end;

procedure TDropPIDLSource.CopyFilePIDLToList(pidl: PItemIDList);
begin
  // Note: Once the PIDL has been copied into the list it can be 'freed'.
  // Make sure that folder pidl has been added.
  if (FPIDLDataFormat.PIDLs.Count < 1) then
    raise Exception.Create(sNoFolderPIDL);
  FPIDLDataFormat.PIDLs.Add(PIDLToString(pidl));
end;

function TDropPIDLSource.GetMappedNames: TStrings;
begin
  Result := FFileMapDataFormat.FileMaps;
end;


////////////////////////////////////////////////////////////////////////////////
//
//		Initialization/Finalization
//
////////////////////////////////////////////////////////////////////////////////

initialization
  // Data format registration
  TPIDLDataFormat.RegisterDataFormat;
  // Clipboard format registration
  TPIDLDataFormat.RegisterCompatibleFormat(TPIDLClipboardFormat, 0, csSourceTarget, [ddRead]);
  TPIDLDataFormat.RegisterCompatibleFormat(TFileClipboardFormat, 1, csSourceTarget, [ddRead]);

finalization
  TPIDLDataFormat.UnregisterDataFormat;

end.