ファイルリストのコピー・ペーストコンポーネント

　エクスプローラとのコピー・貼付け処理を行なうためのコンポーネントです。CF_HDROPフォーマットを使用して、クリップボードとファイルリストをやりとりします。
　またRenderCopyメソッドと、OnRenderFormatイベントを組合わせることで、遅延レンダリング処理を行なうことができます（遅延レンダリングとは、クリップボードへコピーする時点では、クリップボードフォーマットだけを渡しておき、実際に貼付けを行なう時点でWM_RENDERFORMATメッセージを介して、あらためてコピーする実体を渡すという処理です）。拙作LhaMiの最新バージョンでは、この機能を用いて実際にエクスプローラへ貼付けする時点で、圧縮ファイルを解凍するといった処理を実現しています。
　以下をコピーしてファイル名を'CP.pas'として保存し、コンポーネントの登録で登録して下さい。
注）ファイルコピーは実際には「移動」として処理されます。

{*
  エクスプローラとのコピー・貼付け処理コンポーネント
  実際はコピーしたファイルをエクスプローラ上で貼付けすると、それらの
  ファイルは「移動」されます。クリップボードへのCF_HDROPフォーマットを
  用いたファイルリストコピーでは、コピーと移動を制御する方法はないよう
  です。

  プロパティ
    CopyFiles:  TStringList; クリップボードへコピーするファイルのリスト
    PasteFiles: TStringList; クリップボードから張付けしたファイルリスト
  メソッド
    Copy;       CopyFiles内のファイルリストをクリップボードへコピーする
    RenderCopy; クリップボードへ空のファイルリストをコピーする
                エクスプローラ上で貼付けを実行した時点でOnRenderFormat
                イベントが発生する
    Paste;      クリップボード内にCF_HDROPフォーマットのデータがあれば、
                ファイルリストを取出してPasteFilesにセットする
  イベント
    OnRenderFormat;
                RenderCopyを実行後、エクスプローラ上で貼付けを実行した
                時点で呼び出される。必要な処理を行なった後にCopyメソッド
                でファイルリストコピーを実行すれば、実際の貼付けが行わ
                れる。
*}

unit CP;

interface

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

type
  TOnRenderFormatEvent = procedure(Sender: TObject) of Object;
  TCP = class(TComponent)
  private
    { Private 宣言 }
    FCopyFiles,
    FPasteFiles: TStrings;
    FOnRenderFormat: TOnRenderFormatEvent;
    WHandle: THandle;
    FOldWinProc: Pointer;
    FMyProcInstance: Pointer;
    FRenderCount: integer;
    procedure CopyProc;
    procedure RenderCopyProc;
    procedure PasteProc;
    procedure WndProc(var Mess: TMessage);
    procedure SetCopyFiles(const Value: TStrings);
  protected
    { Protected 宣言 }
  public
    { Public 宣言 }
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    procedure Copy;
    procedure RenderCopy;
    procedure Paste;
  published
    { Published 宣言 }
    property CopyFiles: TStrings read FCopyFiles write SetCopyFiles;
    property PasteFiles: TStrings read FPasteFiles;
    property OnRenderFormat: TOnRenderFormatEvent read FOnRenderFormat write FOnRenderFormat;
  end;

procedure Register;

implementation

constructor TCP.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  // サブクラス化でWndProcを横取り
  if not(csDesigning in ComponentState) then
    if Owner is TCustomForm then
      with TCustomForm(Owner) do
      begin
        WHandle:=Handle;
        FMyProcInstance := MakeObjectInstance(WndProc);
        FOldWinProc :=Pointer(GetWindowLong(WHandle, GWL_WNDPROC));
        SetWindowLong(WHandle, GWL_WNDPROC, Integer(FMyProcInstance));
      end;
  FCopyFiles := TStringList.Create;
  FPasteFiles := TStringList.Create;
end;

destructor TCP.Destroy;
begin
  FCopyFiles.Free;
  FPasteFiles.Free;
  OpenClipboard(WHandle);
  EmptyClipboard;
  CloseClipboard;
  inherited Destroy;
end;

// メッセージ処理
procedure TCP.WndProc(var Mess: TMessage);
begin
  case Mess.Msg of
    // 遅延レンダリング
    WM_RENDERFORMAT:
      begin
        // 最初はエクスプローラのコンテキストメニュー表示前にコールされる
        // ため何回か処理をスキップする
        if FRenderCount < 3 then
        begin
          Inc(FRenderCount);
          //SetClipboardData(CF_HDROP, 0);これはなくても良いみたい
        end else begin
          if Assigned(FOnRenderFormat) then
            FOnRenderFormat(nil);
        end;
      end;
  end;
  // 元のWndProcをコールする
  Mess.Result := CallWindowProc(FOldWinProc, WHandle,
                                Mess.Msg,Mess.wParam,Mess.lParam);
end;

// ペースト処理
procedure TCP.PasteProc;
var
  srcbuf : PChar;
  bufhndl : HGLOBAL;
  FileList : PDROPFILES;
  c, gs: integer;
  fname: string;
begin
  OpenClipBoard(WHandle);
  // CF_HDROPフォーマット？
  bufhndl := GetClipBoardData(CF_HDROP);
  if bufhndl = 0 then
  begin
    CloseClipBoard;
    Exit;
  end;
  FPasteFiles.Clear;
  srcbuf:=GlobalLock(bufhndl);
  if srcbuf <> nil then
  begin
    gs := GlobalSize(bufhndl);
    // TDROPFILES構造体の構築
    FileList:=PDROPFILES(srcbuf);
    // WideCharフォーマットで格納時
    if FileList^.fWide then
    begin
      // ヘッダ情報のスキップ
      Inc(srcbuf, SizeOF(TDROPFILES));
      fname := '';
      c := 0;
      // このコードがうごくがどうかは未確認(^^;
      while True do
      begin
        while srcbuf^ <> #0 do
        begin
          fname := fname + srcbuf^;
          Inc(srcbuf);
          Inc(c);
        end;
        FPasteFiles.Add(WideCharToString(PWideChar(fname)));
        Inc(srcbuf, 2);
        Inc(c, 2);
        if (srcbuf^ = #0) or (c >= gs) then
          Break;
        fname := '';
      end;
    // Ansiコード
    end else begin
      //ヘッダ情報のスキップ
      Inc(srcbuf, SizeOF(TDROPFILES));
      fname := '';
      c := 0;
      while True do
      begin
        //#0でファイルを切り出す
        while srcbuf^ <> #0 do
        begin
          fname := fname + srcbuf^;
          Inc(srcbuf);
          Inc(c);
        end;
        FPasteFiles.Add(fname);
        Inc(srcbuf);
        Inc(c);
        //#0が二つ続けば終り。またメモリサイズを越えた場合も終了する
        if (srcbuf^ = #0) or (c >= gs) then
          Break;
        fname := '';
      end;
    end;
  end;
  GlobalUnlock(bufhndl);
  EmptyClipBoard;
  CloseClipBoard;
end;

// コピー処理
procedure TCP.CopyProc;
var
  srcbuf : PChar;
  bufhndl : HGLOBAL;
  FileList : PDROPFILES;
  i: integer;
  fname: string;
begin
  OpenClipboard(WHandle);
  try
    // グローバルメモリのハンドルを取得する
    bufhndl:=GlobalAlloc(GMEM_MOVEABLE, $8000);
    if bufhndl<>0 then
    begin
      // メモリーを固定して、ポインタを得る
      srcbuf:=GlobalLock(bufhndl);
      if srcbuf<>NIL then
      begin
        FillChar(srcbuf^,$8000,0);  // データ内容を0でクリア
        // TDROPFILES構造体の構築
        FileList:=PDROPFILES(srcbuf);
        with FileList^ do
        begin
          pFiles:=SizeOF(TDROPFILES);
          pt.x:=0;
          pt.y:=0;
          fNC:=FALSE;
          fWide:=FALSE;   // ANSI文字列(ShiftJIS文字列)を使用する
        end;
        // srcbufをTDROPFILESポインタの後ろへ移動
        Inc(srcbuf, SizeOF(TDROPFILES));
        // コピーファイル名を入れる
        for i := 0 to FCopyFiles.Count - 1 do
        begin
          fname := FCopyFiles.Strings[i];
          StrPCopy(srcbuf, fname);
          Inc(srcbuf, Length(fname) + 1);
        end;
        // 成功したらアンロックして、メモリハンドルをクリップボードに渡す
        GlobalUnlock(bufhndl);
        SetClipBoardData(CF_HDROP,bufhndl);
      end else
        GlobalFree(bufhndl);  // 失敗したらメモリーを解放
    end;
  finally
    CloseClipBoard;
  end;
end;

// 遅延レンダリングコピー
procedure TCP.RenderCopyProc;
begin
  OpenClipBoard(WHandle);
  EmptyClipBoard;
  // 何のことはない、データに0をセットしてコピーするだけ
  SetClipBoardData(CF_HDROP, 0);
  CloseClipBoard;
end;

// CopyFilesのセット
procedure TCP.SetCopyFiles(const Value: TStrings);
begin
  FCopyFiles.Assign(Value);
end;

// コピーメソッド
procedure TCP.Copy;
begin
  if FCopyFiles.Count > 0 then
    CopyProc;
end;

// ペーストメソッド
procedure TCP.Paste;
begin
  PasteProc;
end;

// 遅延レンダリングコピーメソッド
procedure TCP.RenderCopy;
begin
  FRenderCount := 0;
  RenderCopyProc;
end;

procedure Register;
begin
  RegisterComponents('User6', [TCP]);
end;

end.

　このユニットの使用は改変や一部流用も含めて自由です。

戻る