[BlueLeaf1336]> PROGRAM>

エクスプローラからのドラッグ&ドロップ受付

history

TOP

2003/09/20:作成
2003/04/07:開始・停止をコマシに

overview

TOP

比較的簡単に、自分のアプリケーションがエクスプローラからのドラッグ&ドロップを受け付けるようにできるクラスです。
しかも、コンポーネントパレットを汚しません。

インスタンスの作成時に、ドロップを受け付けるコンポーネント(たとえばTMemoとかTEditなど)と、受け付け通知用の関数を引数に渡してやるだけでOKです。
でもひょっとしたら、クラス側で通知用関数の呼び出し前に受付を一時停止して、関数呼び出し後に再開するような処理がいるような気がします。 受付関数の処理が何十秒とかかる場合、もっかいドロップされてしまったらどうなるの?みたいな不安が...

reference

TOP

http://www.psn.ne.jp/~nagayama/program/0017.html

download

TOP

iDragDrop.zip(2,203bytes):ソース

code

TOP

(*
    #######################################################

    目的    :   Shellからのドラッグアンドドロップを受け付ける
    履歴    :   2003/09/20 作成
                2004/04/07 開始・停止をコマシに

    使用例  :   var
                    Dropper: TShellDrop;

                procedure   TForm1.DroppedAction(AFiles, AFolds: TStringList;
                            AControl: TControl; APos: TPoint);
                begin
                    Memo1.Clear;
                    Memo1.Lines.Add(StringOfChar('=', 50));
                    Memo1.Lines.Add(AControl.Name);
                    Memo1.Lines.Add(StringOfChar('=', 50));
                    Memo1.Lines.Add(Format('X%3d:Y%3d', [APos.X, APos.Y]));
                    Memo1.Lines.Add(StringOfChar('=', 50));
                    Memo1.Lines.AddStrings(AFiles);
                    Memo1.Lines.Add(StringOfChar('=', 50));
                    Memo1.Lines.AddStrings(AFolds);
                    Memo1.Lines.Add(StringOfChar('=', 50));
                end;

                procedure TForm1.FormCreate(Sender: TObject);
                begin
                    Dropper := TShellDrop.Create(Memo1, DroppedAction);
                    Dropper.Start();
                end;

                procedure TForm1.FormDestroy(Sender: TObject);
                begin
                    Dropper.Free;
                end;

    参考文献:   http://www.psn.ne.jp/~nagayama/program/0017.html


    #######################################################
*)

unit iDragDrop;

interface

uses
    Windows, Messages, Classes, Controls;

type
    TOnShellDropped = procedure(AFiles, AFolds: TStringList;
                                AControl: TControl; APos: TPoint) of object;
//    TOnShellDropped = procedure(AFiles, AFolds: TStringList;
//                                AControl: TControl; APos: TPoint);


    TShellDrop = class
    private
        FTarget     : TWinControl;

        FOldWndProc : Pointer;
        FNewWndProc : Pointer;
        FWndHandle  : HWND;
        FEnabled    : Boolean;

        DropFileList: TStringList;
        DropFoldList: TStringList;
        DropPos     : TPoint;
        DropControl : TControl;

        FOnDropped  : TOnShellDropped;

        procedure   WndProc(var Msg: TMessage); virtual;
        procedure   UpdateDropList(AFileName: string);
    public
        constructor Create(ATarget: TWinControl; AOnDropped: TOnShellDropped);
        destructor  Destroy; override;
        procedure   Start();
        procedure   Stop();
    published

    end;

implementation

uses
    ShellApi, SysUtils, Forms;


//------------------------------------------------------------------------------
(* ドロップファイルリスト更新 *)
procedure   TShellDrop.UpdateDropList(AFileName: string);
begin
    // フォルダ？
    if DirectoryExists(AFileName) then
    begin
        DropFoldList.Add(AFileName);
    end else
    // ファイル？
    if FileExists(AFileName) then
    begin
        DropFileList.Add(AFileName);
    end else
    // だれだおまえ？
    begin
        ;
    end;
end;

//------------------------------------------------------------------------------
(* コンストラクタ *)
constructor TShellDrop.Create(ATarget: TWinControl; AOnDropped: TOnShellDropped);
begin
    // のっとりコントロール保存
    FTarget := ATarget;
    // そのハンドル保存
    FWndHandle  := FTarget.Handle;
    // 通知関数保存
    FOnDropped := AOnDropped;

    // 準備
    DropFileList := TStringList.Create;
    DropFoldList := TStringList.Create;
    DropPos      := Point(-1, -1);
    DropControl  := nil;
    // とりあえず無効に
    FEnabled := False;
    // 置き換えWindowProcedureをオブジェクトに(自信なし。推奨されないようで)
    FNewWndProc := Classes.MakeObjectInstance(WndProc);
    // 置き換えてオリジナルを保存
    FOldWndProc := Pointer(SetWindowLong(FWndHandle,GWL_WNDPROC,LongInt(FNewWndProc)));
end;

//------------------------------------------------------------------------------
(* デストラクタ *)
destructor  TShellDrop.Destroy;
begin
    if FEnabled then Stop();
    // 元に戻そう
    SetWindowLong(FWndHandle, GWL_WNDPROC, LongInt(FOldWndProc));
    // リスト開放とか
    DropFileList.Free;
    DropFoldList.Free;
    DropPos      := Point(-1, -1);
    DropControl  := nil;
    inherited;
end;

//------------------------------------------------------------------------------
(* メイン *)
procedure TShellDrop.WndProc(var Msg: TMessage);
var
    WMDropFiles: TWMDropFiles;
    i          : integer;
    FileName   : array [0..255] of Char;
    FileCount  : integer;
begin
    // ドロップされたよメッセージかつ有効状態
    if (Msg.Msg = WM_DROPFILES) then
    begin
        // キャスト
        WMDropFiles := TWMDropFiles(Msg);
        try
            //ドロップ位置
            DragQueryPoint(WMDropFiles.Drop, DropPos);
            //ドロップ位置のコントロール
            DropControl := FindDragTarget(FTarget.ClientToScreen(DropPos), False);
            //ドロップファイル数
            FileCount := DragQueryFile(WMDropFiles.Drop, $FFFFFFFF, FileName, SizeOf(FileName));
            //リストクリア
            DropFileList.Clear;
            DropFoldList.Clear;
            // 全ファイルに対して
            for i := 0 to FileCount - 1 do
            begin
                // どないよ？
                DragQueryFile(WmDropFiles.Drop, i, FileName, SizeOf(FileName));
                // ファイル？フォルダ？
                UpdateDropList(FileName);
            end;
            // 終了
            DragFinish(WmDropFiles.Drop);
            // 通知
            FOnDropped(DropFileList, DropFoldList, DropControl, DropPos);
        except
            // 問題発生
            Application.HandleException(Self);
        end;
    end else
    begin
        // 他のメッセージは知らんよ。どうにかして。
        Msg.Result := CallWindowProc(FOldWndProc, FWndHandle, Msg.Msg, Msg.wParam, Msg.lParam);
    end;
end;

//------------------------------------------------------------------------------
(* 受け付けるよ *)
procedure   TShellDrop.Start();
begin
    if FEnabled then exit;
    DragAcceptFiles(FWndHandle, true);
    FEnabled := True;
end;

//------------------------------------------------------------------------------
(* 受け付けません *)
procedure   TShellDrop.Stop();
begin
    if not FEnabled then exit;
    DragAcceptFiles(FWndHandle, False);
    FEnabled := False;
end;

end.

sample

TOP

unit Main;

interface

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

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    procedure   DroppedAction(AFiles, AFolds: TStringList; AControl: TControl; APos: TPoint);
  public

  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses
    iDragDrop;

var
    Dropper: TShellDrop;

// ドロップされた時に呼び出される通知用の関数
procedure   TForm1.DroppedAction(AFiles, AFolds: TStringList; AControl: TControl; APos: TPoint);
begin
    Memo1.Clear;
    Memo1.Lines.Add(StringOfChar('=', 50));
    Memo1.Lines.Add(AControl.Name);
    Memo1.Lines.Add(StringOfChar('=', 50));
    Memo1.Lines.Add(Format('X%3d:Y%3d', [APos.X, APos.Y]));
    Memo1.Lines.Add(StringOfChar('=', 50));
    Memo1.Lines.AddStrings(AFiles);
    Memo1.Lines.Add(StringOfChar('=', 50));
    Memo1.Lines.AddStrings(AFolds);
    Memo1.Lines.Add(StringOfChar('=', 50));
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
    // 作って
    Dropper := TShellDrop.Create(Memo1, DroppedAction);
    // 開始するだけ
    Dropper.Start();
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
    // 超重要。ドロップ終了処理
    Dropper.Free;
end;

end.

EOF

TOP