如何使我的文件 DropSouce 被所有使用文件的目标接受？

Question

我制作了一个表示文件列表的控件，我希望能够将文件从我的控件拖到其他处理文件的应用程序。我实现了 IDragSource 接口（如下所示），但是当我拖动时，文件仅被 windows 资源管理器接受，其他应用程序如 Firefox、Yahoo Messenger、Photoshop...不接受我的文件。我做错了什么？我觉得 IDataObject 设置不正确，恐怕我必须自己实现它......这对我来说是一项非常复杂的工作，因为我刚刚开始使用接口。

这里是重现问题的代码：

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ActiveX, ShlObj;

type
  TMyControl = class(TMemo, IDropSource)
  private
   function QueryContinueDrag(fEscapePressed:BOOL; grfKeyState:Longint):HResult; stdcall;
   function GiveFeedback(dwEffect:Longint):HResult; stdcall;
   procedure DoDragAndDrop;
   function GetFileListDataObject:IDataObject;
  protected
   procedure MouseMove(Shift:TShiftState; X,Y:Integer); override;
  end;

  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  public
    MyMemo:TMyControl;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{TMyControl}

function TMyControl.QueryContinueDrag(fEscapePressed:BOOL; grfKeyState:Longint):HResult;
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:=S_OK;
end;

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

procedure TMyControl.DoDragAndDrop;
var AllowedEffects,DropEffect:Longint;
    DataObj:IDataObject;
begin
 AllowedEffects:=DROPEFFECT_COPY;
 DataObj:=GetFileListDataObject;
 if DataObj <> nil then
  DoDragDrop(DataObj, self, AllowedEffects, DropEffect);
end;

function TMyControl.GetFileListDataObject:IDataObject;
var Desktop:IShellFolder;
    Attr,Eaten:ULONG;
    Count,x:Integer;
    Pidls:array of PItemIDList;
begin
 Result:=nil;
 Count:=Lines.Count;
 if Count<1 then Exit;
 if Failed(SHGetDesktopFolder(Desktop)) then Exit;
 SetLength(Pidls,Count);
 for x:=0 to Count-1 do Pidls[x]:=nil;
 try
  for x:=0 to Count-1 do
   if Failed(Desktop.ParseDisplayName(0, nil, PWideChar(Lines[x]), Eaten, Pidls[x], Attr)) then Exit;
  Desktop.GetUIObjectOf(0, Count, Pidls[0], IDataObject, nil, Result);
 finally
  for x:=0 to Count-1 do
   if Pidls[x]<>nil then CoTaskMemFree(Pidls[x]);
 end;
end;

procedure TMyControl.MouseMove(Shift:TShiftState; X,Y:Integer);
begin
 if ssLeft in Shift then DoDragAndDrop;
 inherited;
end;

//---------------------------------

procedure TForm1.FormCreate(Sender: TObject);
begin
 MyMemo:=TMyControl.Create(Form1);
 MyMemo.Parent:=Form1;
 MyMemo.Align:=alClient;
end;

end.

Answer 1

问题是您使用了不正确的 Desktop.GetUIObjectOf 调用。当您调用 SomeFolder.GetUIObjectOf 时，项目必须是 SomeFolder 的子项。但就您而言，情况并非如此。尝试这样的事情：

type
  PPItemIDList = ^PItemIDList;

function GetFileListDataObject(AParentWnd: HWND; const APath: string; AFileNames: TStrings): IDataObject;
var
  Desktop: IShellFolder;
  Eaten, Attr: ULONG;
  i: Integer;
  PathIDList: PItemIDList;
  PathShellFolder: IShellFolder;
  IDLists: PPItemIDList;
  IDListsSize: Integer;
  Pos: PPItemIDList;
begin
  Result := nil;
  if AFileNames.Count < 1 then Exit;

  if Failed(SHGetDesktopFolder(Desktop)) then Exit;
  try
    Attr := 0;
    if Failed(Desktop.ParseDisplayName(AParentWnd, nil, PWideChar(APath), Eaten, PathIDList, Attr)) then Exit;
    try
      if Failed(Desktop.BindToStorage(PathIDList, nil, IShellFolder, PathShellFolder)) then Exit;
      try
        IDListsSize := SizeOf(PItemIDList) * AFileNames.Count;
        GetMem(IDLists, IDListsSize);
        try
          ZeroMemory(IDLists, IDListsSize);
          Pos := IDLists;
          for i := 0 to AFileNames.Count - 1 do
            begin
              Attr := 0;
              if Failed(PathShellFolder.ParseDisplayName(0, nil, PWideChar(AFileNames[i]), Eaten, Pos^, Attr)) then Exit;
              Inc(Pos);
            end;
          PathShellFolder.GetUIObjectOf(0, AFileNames.Count, IDLists^, IDataObject, nil, Result);
        finally
          Pos := IDLists;
          for i := 0 to AFileNames.Count - 1 do
            begin
              if Assigned(Pos^) then
                CoTaskMemFree(Pos^);
              Inc(Pos);
            end;
          FreeMem(IDLists);
        end;
      finally
        PathShellFolder := nil;
      end;
    finally
      CoTaskMemFree(PathIDList);
    end;
  finally
    Desktop := nil;
  end;
end;

如何使我的文件 DropSouce 被所有使用文件的目标接受？

How to make my file DropSouce be accepted by all targets that works with files?

delphi

drag-and-drop

interface

delphi-2009