Delphiのコンポーネントから外部アプリへドラッグ＆ドロップする方法（ソース公開）

## はじめに

DelphiのVCL環境では、標準機能によりフォーム内コンポーネント間のドラッグ＆ドロップは可能です。しかし、**Chromeやエクスプローラーなど、Delphi以外のアプリケーションへのD&Dには非対応**であり、ドキュメントや実装例もほとんど存在しません。

この記事では、その制限を超えて「**Delphiから外部アプリへドラッグ＆ドロップ**」を可能にするクラスを紹介し、そのソースコードを公開します。

---

そのクラスの名は **TDragFile**クラスです。
姉妹品の外部アプリから受け取る **TDropfile**も近日公開予定

## 主な特徴

- **VCLアプリケーションに対応**
- **TListBox、TListView、TMemoなど様々なコンポーネントに対応**
- **クラスを生成してアタッチするだけで簡単に利用可能**

```pascal
Drag := TDragFile.Create(Self);
Drag.Attach(ListBox1);
```

---

## 使用例

以下は `TListBox` にアタッチして、アイテムをD&Dで渡す例です。

```pascal
Drag := TDragFile.Create(Self);
Drag.Attach(ListBox1);
Drag.OnDragRequest := procedure(Sender: TObject; var AFilePath: string)
begin
  if ListBox1.ItemIndex >= 0 then
  begin
    // 実在するファイルを指定する必要があります
    AFilePath := 'C:\Temp\' + ListBox1.Items[ListBox1.ItemIndex] + '.txt';
  end;
end;
```

🛑 **注意**：D&D先が実ファイルを要求するため、**指定するパスは存在するファイルである必要があります**。存在しないパスを指定すると受け取り側で無視される場合があります。

---

## ソースコード

ソースコード（DragFile.pas）は以下のGitHub Gistまたは添付ファイルから取得できます

```DragFile.pas
unit DragFile;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, ActiveX, ShlObj, ComObj,
  Vcl.StdCtrls,System.Types,Vcl.ExtCtrls;

type TDragFileRequest = procedure (Sender : TObject;FileNames : TStringList) of object;
type TDragFileTarget = procedure (Sender: TObject; Button: TMouseButton;Shift: TShiftState; X, Y: Integer) of object;



//--------------------------------------------------------------------------//
//  ドラッグ＆ドロップを管理するクラス                                      //
//--------------------------------------------------------------------------//
type
  TDragFile = class(TWinControl,IDropSource)
  private
    { Private 宣言 }
    FTimer          : TTimer;                   // ダブルクリック後のマウス処理を無効にするタイマー
    FDragStartPos   : TPoint;                   // ドラッグ開始マウス座標
    FDragFolder     : string;                   // ドロップ先へ送るフォルダ名
    FDragFiles      : TStringList;              // ドロップ先へ送るファイル一覧(Pathなし)
    FDataObject     : IDataObject;              // ドロップ先へ送るデータの管理
    FIsDragging     : Boolean;                  // True :マウスドラッグ中
    FMouseDown      : Boolean;                  // True :マウスクリック中
    FMouseDBClicked : Boolean;                  // True : マウスクリック直後
    FTarget         : TWinControl;              // ターゲット可変にするためTWinControlを使用

    FOnDragTarget   : TDragFileTarget;
    FOnDragCancel   : TNotifyEvent;
    FOnDragRequest  : TDragFileRequest;         // ドラッグ時のデータ要求イベント
    FOnDragging     : TNotifyEvent;

    FOldMouseDown   : TMouseEvent;              // ドラッグ機能を割り当てる前のイベントを保存
    FOldMouseMove   : TMouseMoveEvent;
    FOldMouseUp     : TMouseEvent;

    function GetFileListDataObject(const Directory: string; Files: TStrings):IDataObject;
    procedure SetDragFiles(ts : TStringList);

    // フォルダ名とファイル一覧からターゲットに渡すデータを作成
    procedure MakeData();
    // データをターゲットに送信
    procedure DataDrop();
    procedure OnTimer(Sender: TObject);
    // マウス降下時に呼ぶ処理 OnMouseDown に直接割り当てても良い
    procedure CtrlMouseDown(Sender: TObject; Button: TMouseButton;Shift: TShiftState; X, Y: Integer);
    // マウス上昇時に呼ぶ処理 OnMouseUp に直接割り当てても良い
    procedure CtrlMouseUp(Sender: TObject; Button: TMouseButton;Shift: TShiftState; X, Y: Integer);
    // マウス移動時に呼ぶ処理 OnMouseMoveに直接割り当てても良い
    procedure CtrlMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
  protected
    procedure DoDragTarget(Button: TMouseButton;Shift: TShiftState; X, Y: Integer);
    procedure DoDragCancel();
    procedure DoDragging();
    procedure DoDragRequest(FileNames : TStringList);
    // ドラッグ中に発生するイベント
    function QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: Longint): HResult; stdcall;
    function GiveFeedback(dwEffect: Longint): HResult; stdcall;
  public
    { Public 宣言 }
    constructor Create(AOwner: TComponent);override;
    destructor Destroy;override;

    // 指定したクラスにドラッグの機能を実装
    procedure Attach(Control: TWinControl);
    // クラスに実装したドラッグの機能を解除
    procedure Detach;
    // ドラッグ操作を強制キャンセル
    procedure CtrlDragCancel(Sender: TObject);

    // ドラッグ元のコントロール
    property Target : TWinControl read FTarget;
    // True : ドラッグ中
    property IsDragging : Boolean read FIsDragging;

    // ドラッグされたときに発生するイベント
    property OnDragTarget : TDragFileTarget read FOnDragTarget write FOnDragTarget;
    // ドラッグが中断されたときに発生するイベント
    property OnDragCancel : TNotifyEvent read FOnDragCancel write FOnDragCancel;
    // ドラッグが開始されたときに発生するイベント
    property OnDragging : TNotifyEvent read FOnDragging write FOnDragging;
    // ドラッグのデータ生成要求イベント
    property OnDragRequest : TDragFileRequest read FOnDragRequest write FOnDragRequest;
  end;


implementation

procedure DebugLogMsg(const Msg: string);
begin
  {$IFDEF DEBUG}
  OutputDebugString(PChar(Msg));
  {$ENDIF}
end;



{ TDragFile }

constructor TDragFile.Create(AOwner: TComponent);
begin
  inherited;
  FTimer := TTimer.Create(nil);
  FTimer.Interval := 1000;
  FTimer.Enabled := False;
  FTimer.OnTimer := OnTimer;
  FDragFiles := TStringList.Create;
end;

destructor TDragFile.Destroy;
begin
  FTimer.Free;
  FDragFiles.Free;
  inherited;
end;

type
  TWinControlAccess = class(TWinControl);

procedure TDragFile.Attach(Control: TWinControl);
var
  Access: TWinControlAccess;
begin
  if Assigned(FTarget) then
    Detach;

  FTarget := Control;
  Access := TWinControlAccess(Control);  // ← protectedにアクセスするための型キャスト

  FOldMouseDown := Access.OnMouseDown;
  FOldMouseMove := Access.OnMouseMove;
  FOldMouseUp   := Access.OnMouseUp;

  Access.OnMouseDown := CtrlMouseDown;
  Access.OnMouseMove := CtrlMouseMove;
  Access.OnMouseUp   := CtrlMouseUp;
end;

procedure TDragFile.Detach;
var
  Access: TWinControlAccess;
begin
  if not Assigned(FTarget) then Exit;

  Access := TWinControlAccess(FTarget);
  Access.OnMouseDown := FOldMouseDown;
  Access.OnMouseMove := FOldMouseMove;
  Access.OnMouseUp   := FOldMouseUp;

  FTarget := nil;
end;

function TDragFile.GetFileListDataObject(const Directory: string;
  Files: TStrings): IDataObject;
type
  PArrayOfPItemIDList = ^TArrayOfPItemIDList;
  TArrayOfPItemIDList = array[0..0] of PItemIDList;
var
  Malloc       : IMalloc;
  Root         : IShellFolder;
  FolderPidl   : PItemIDList;
  Folder       : IShellFolder;
  chEaten      : ULONG;
  dwAttributes : ULONG;
  FileCount    : Integer;
  p            : array of PItemIDList;
  i            : Integer;
begin
  Result := nil;
  if Files.Count = 0 then Exit;
  OleCheck(SHGetMalloc(Malloc));
  OleCheck(SHGetDesktopFolder(Root));
  OleCheck(Root.ParseDisplayName(0, nil, PWideChar(WideString(Directory)),
    chEaten, FolderPidl, dwAttributes));
  try
    OleCheck(Root.BindToObject(FolderPidl, nil, IShellFolder,
      Pointer(Folder)));
    FileCount := Files.Count;
    SetLength(p,FileCount);
    for i := 0 to FileCount - 1 do begin
      OleCheck(Folder.ParseDisplayName(0, nil,
        PWideChar(WideString(Files[i])), chEaten, p[i], dwAttributes));
    end;
    OleCheck(Folder.GetUIObjectOf(0, FileCount, p[0], IDataObject, nil,
      Pointer(Result)));
  finally
    Malloc.Free(FolderPidl);
  end;
end;

function TDragFile.GiveFeedback(dwEffect: Integer): HResult;
begin
  result := DRAGDROP_S_USEDEFAULTCURSORS;
end;

procedure TDragFile.MakeData;
var
  slst : TStringList;
  i : Integer;
begin
  slst := TStringList.Create;
  try
    if FDragFiles.Count = 0 then exit;

    for i := 0 to FDragFiles.Count-1 do begin                    // ファイルの数だけループ
      slst.Add(FDragFiles[i]);                                   // ファイルを追加
    end;
    FDataObject := GetFileListDataObject(FDragFolder,slst);      //ファイル名からIDataObjectを取得
  finally
    slst.Free;
  end;
end;

procedure TDragFile.OnTimer(Sender: TObject);
begin
  FMouseDBClicked := False;
end;

procedure TDragFile.DataDrop;
var
  dwEffect : Integer;
begin
  //OLEドラッグ＆ドロップ開始
  dwEffect := DROPEFFECT_NONE;
  DoDragDrop(FDataObject, Self, DROPEFFECT_COPY, dwEffect);
end;

procedure TDragFile.CtrlDragCancel(Sender: TObject);
begin
  FMouseDBClicked := True;
  FTimer.Enabled := True;

  FDragFiles.Clear;                                   // ドラッグ対象を初期化
  MakeData();                                         // ドラッグデータを初期化
  DoDragCancel();                                     // キャンセルを通知
  FTarget.EndDrag(False);                             // ドラッグ状態を解除
end;


procedure TDragFile.CtrlMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  FileNames : TStringList;
begin
  if Button <> mbLeft then exit;                      // 左クリック降下中でなければ処理しない

  if FMouseDBClicked then exit;                       // マウスクリック直後は処理しない

  FileNames := TStringList.Create;
  try
    FTarget.EndDrag(False);                           // 一度ドラッグを解除
    FMouseDown := True;                               // マウス降下状態を記憶
    DoDragRequest(FileNames);                         // D&D用データ作成要求
    DoDragTarget(Button,Shift,X,Y);                   // ドラッグ座標を通知
    if FileNames.Count = 0 then exit;                 // データが作成されていない場合は処理しない

    SetDragFiles(FileNames);                          // 指定されたファイル名をドロップデータとする
    FDragStartPos := Point(X, Y);                     // ドラッグ開始座標として記録

  finally
    FileNames.Free;
  end;
end;

procedure TDragFile.CtrlMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
const
  Threshold = 16;                                          // マウス移動距離
var
  f : Boolean;
begin
  if not FMouseDown then exit;

  f := False;
  if ((Abs(X - FDragStartPos.x) >= Threshold)
    or (Abs(Y - FDragStartPos.y) >= Threshold)) then begin // ボタン降下位置から一定距離離れた場合
    f := True;                                             // ドラッグ中とする
    DoDragging();                                          // ドラッグの開始を通知
  end;
  if not f then exit;                                      // ドラッグ中判定中は処理しない

  if (FMouseDown) and (not FIsDragging) then begin         // マウス降下後の最初のマウス移動の場合
    if FMouseDBClicked then exit;                          // ダブルクリックの可能性がある場合未処理
    FTarget.BeginDrag(True);                               // ドラッグ処理を開始
    FIsDragging := True;                                   // ドラッグ中とする
    MakeData();                                            // データを要求
    DataDrop();                                            // ドラッグ中として振る舞う
  end;
end;

// マウス上昇イベント　※ドラッグ中はドラッグの最中に発生する
procedure TDragFile.CtrlMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FMouseDown := False;                                     // マウス降下状態をリセット
  FIsDragging := False;                                    // ドラッグ状態をリセット
  DoDragCancel();                                          // キャンセルを通知
  FTarget.EndDrag(False);                                  // ドラッグ状態を解除
end;

function TDragFile.QueryContinueDrag(fEscapePressed: BOOL;
  grfKeyState: Integer): HResult;
begin
  if fEscapePressed or
     (grfKeyState and MK_RBUTTON = MK_RBUTTON) then begin  // ドラッグ操作が解除された場合
    result := DRAGDROP_S_CANCEL;                           // アイコンを解除状態に
    DebugLogMsg('DRAGDROP_S_CANCEL');
    FTarget.EndDrag(False);                                // ドラッグを解除
  end
  else if grfKeyState and MK_LBUTTON = 0 then begin        // ドロップ先が決まった場合
    result := DRAGDROP_S_DROP;                             // アイコンをドロップ状態に
    DebugLogMsg('DRAGDROP_S_DROP');
    DoDragCancel();                                        // ドロップの終了処理を通知
    FTarget.EndDrag(False);                                // ドラッグ操作を解除
    FMouseDown := False;                                   // マウス降下状態をリセット
    FIsDragging := False;                                  // ドラッグ状態をリセット
  end else begin
    result := S_OK;
  end;

end;

procedure TDragFile.SetDragFiles(ts: TStringList);
var
  i: Integer;
begin
  if ts.Count = 0 then exit;
  FDragFolder := ExtractFilePath(ts[0]);
  FDragFiles.Clear;
  for i := 0 to ts.Count-1 do begin
    FDragFiles.Add(ExtractFileName(ts[i]));
  end;
end;


procedure TDragFile.DoDragCancel;
begin
  DebugLogMsg('DO_DRAG_CANCEL');
  if Assigned(FOnDragCancel) then begin
    FOnDragCancel(Self);
  end;
end;

procedure TDragFile.DoDragRequest(FileNames : TStringList);
begin
  DebugLogMsg('DO_DRAG_REQUEST');
  if Assigned(FOnDragRequest) then begin
    FOnDragRequest(Self,FileNames);
  end;
end;

procedure TDragFile.DoDragging;
begin
  if Assigned(FOnDragging) then begin
    FOnDragging(Self);
  end;
end;

procedure TDragFile.DoDragTarget(Button: TMouseButton;Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(FOnDragTarget) then begin
    FOnDragTarget(Self,Button,Shift,X,Y);
  end;
end;


initialization
  OleInitialize(nil);
finalization
  OleUninitialize;

end.
```

## ライセンス表記

このソースの利用にライセンス表記は不要です。
あればうれしいだけ
ソースの改変や再配布も可能です。
「私が作りました」と勝手に名乗るのだけはお止めください。

---

## おわりに

情報の少ないこの分野において、少しでも参考になれば幸いです。
たかがドラッグアンドドロップ操作と思いますが制作に1年近くかかっています。
改良案やフィードバックがあればぜひコメントください。