エクスプローラからのドラッグ&ドロップをサブクラスを使って実現した例
 少し試した限りでは大丈夫だけど安全性は保証の限りではない。
 間違いあれば ゴメンナサイ(^^;



unit SubClass;
interface
uses
  Windows, Messages,  Classes, Controls,Forms,ShellAPI;
type
{ Windowハンドルからメッセージをサブクラス化するコンポーネント
 つまりWindowsからのコントロール/フォームへのメッセージを横取り出来る。
 複数置いた場合は、最初に置いたコンポーネントからメッセージを貰う。
  このコンポーネントは継承し、Connectメソッドで開始し利用する事
  他のコンポと共用出来ないメッセージ応答処理をしたら IsBreakをセットする
   }
  TSubClass = class(TComponent)
  protected
    IsServer    : Boolean;     {自分がサーバならTrue}
    IsClient    : Boolean;     {自分がClientならTrue}
    WHandle     : THandle;     {対象にするウインドハンドル}
  private
        SubClassList   : TList;    {自分がSaverの時複数のSubClass}
        FOldWinProc    : Pointer;  {Server時 置換した元WinProc}
        FMyProcInstance: Pointer;  {Server時 自分のInstance}
       MyServer  :TSubClass;       {自分がClientの時の親}
    function  AddList(colleague:TSubClass):Boolean;//他のコンポが追加された
    procedure DelList(colleague:TSubClass);        //他のコンポが削除された
    procedure WndProc(var Message: TMessage);
    procedure StartServer;
    procedure EndServer;
  public
    IsBreak:Boolean;                           {他のに処理させたくない}
    procedure  Connect(Window:THandle);virtual;{メッセージ処理の開始}
    procedure  DisConnect             ;virtual;{メッセージ処理の終了}
    destructor Destroy; override;
//  procedure DefaultHandler(var Message);Override; {今回使わなかった}
  published
  end;

//////////////////////////////////
{ TSubClass使用例:  WM_DropFiles  }

 TDropFileEvent = procedure(Sender: TObject; Msg: TStrings) of object;
 TDropFiles = class(TSubClass)
  private
   FEnable:Boolean;
   FParent:TWinControl;
   FOnDropFile    : TDropFileEvent;
   procedure  WMDropFiles(var Msg: TWMDropFiles) ; message WM_DROPFILES;
   procedure SetParent(s:TWinCOntrol);
   procedure SetEnable(f:Boolean);
  public
   procedure  Connect(Window:THandle);override;{メッセージ処理の開始}
   procedure  DisConnect;             override;{メッセージ処理の終了}

   procedure  Loaded;override;
   destructor Destroy; override;
  published
   property Parent    :TWinControl  read Fparent     write SetParent;
   property Enable    :boolean      read FEnable     write SetEnable;
   property OnDropFile: TDropFileEvent read FOnDropFile write FOnDropFile;
  end;

procedure Register;

implementation

{サーバーとしてメッセージの受信}
procedure TSubClass.WndProc(var Message: TMessage);
var i:Integer;
begin
 if Not IsServer then raise EInvalidOperation.Create('ありえない');
 IsBreak:=False;
  try
   Dispatch(Message);
  except
    Application.HandleException(Self);
  end;
   if IsBreak then Exit;  {そのメッセージが処理されたら他は呼ばない}

   with SubClassList do     //リストをたどって他のにも同じメッセージを渡す
   for i:=0 to  Count-1 do
   begin
      TSubClass(Items[i]).Dispatch(Message);
      if IsBreak then Exit;  {そのメッセージが処理されたら}
   end;
  with TMessage(Message) do
    Result:=CallWindowProc(FOldWinProc, WHandle, Msg, WParam, LParam);
end;
//他のコンポが追加された
function  TSubClass.AddList(colleague:TSubClass):Boolean;
begin
 Result:=False;
  if IsServer then   begin
   SubClassList.Add(colleague);
   Result:=True;
  end;
end;
//他のコンポが削除された
procedure TSubClass.DelList(colleague:TSubClass);
begin
  if IsServer then   begin
   SubClassList.Remove(colleague);
  end;
end;

{SubClass化の開始}
procedure TSubClass.StartServer;
begin
 IsClient:=False;
 FMyProcInstance:=MakeObjectInstance(WndProc);
 FOldWinProc    :=Pointer(GetWindowLong(WHandle, GWL_WNDPROC));
 SetWindowLong(WHandle, GWL_WNDPROC, Integer(FMyProcInstance));
 IsServer:=True;
 try
  if Assigned(SubClassList) then SubClassList:=TList.Create;
 except
   IsServer:=False;
   SetWindowLong(WHandle,GWL_WNDPROC,Integer(FOldWinProc));//元に戻す
 end;
end;

{リストをたどって既にサーバが開設されていないか調べる}
function FindServer(s:tComponent;Handle:THandle):TSubClass;
var i:integer;
var d:tComponent;
begin
 for i:=0 to s.ComponentCount-1 do
  begin
  d:=s.Components[i];
   if  d is TSubClass Then  with TSubClass(d) do
   if IsServer And(WHandle=Handle) then
    begin
    Result:=TSubClass(d);
    exit;
    end;
  end;
   Result:=nil;
end;

{サーバかクライアントにするかしてメッセージ処理開始}
procedure TSubClass.Connect(Window:THandle);
begin
 WHandle:=Window;
 if IsServer or IsClient then Exit; //既にConnectされていれば
 MyServer:=FindServer(Owner,Window);
 if Assigned(MyServer) then begin //もし既にサーバがあれば
   MyServer.AddList(Self);        //自分を登録して終了
   IsClient:=True;
  end else begin
   SubClassList:=TList.Create;
   StartServer;
  end;
end;

{SubClass化の終了}
procedure TSubClass.EndServer;
var p:Pointer;
begin
if  IsServer then
 begin
   IsServer:=False;
   p:=Pointer(GetWindowLong(WHandle, GWL_WNDPROC));
   if FMyProcInstance=p then
    SetWindowLong(WHandle,GWL_WNDPROC,Integer(FOldWinProc)) //元に戻す
 end;
end;
{メッセージ処理終了}
procedure TSubClass.DisConnect;
var s:TSubClass;
begin
 if IsServer then begin
   if SubClassList.Count > 0 then begin
      s:=SubClassList.Last;
      SubClassList.Remove(s);      //子の最後を削除して
      s.SubClassList:=SubClassList;//子に子のリストを渡し
      EndServer;                   //自分のサブクラスを解除
      s.StartServer;               //子をサーバとして開始させる
    end else  begin                //子が無いので
      SubClassList.Free;
      EndServer;
    end;
 end else
 if IsClient then begin
    IsClient:=False;
    MyServer.DelList(Self);        //サーバに対して自分の終了を指示する
 end;
end;
destructor TSubClass.Destroy;
begin
   DisConnect;
  inherited Destroy;
end;

{#########################
 ファイルドロップ処理
 #########################}
procedure TDropFiles.WMDropFiles(var Msg: TWMDropFiles) ;
var
  CFileName: array[0..MAX_PATH] of Char;
  i,FileCount:integer;
  s:TStringList;
begin
 try
     s:=TStringList.Create;
     FileCount:=DragQueryFile(Msg.Drop, -1, nil, MAX_PATH);
   for i:=0 to FileCount-1 do
    if  DragQueryFile(Msg.Drop, i, CFileName, MAX_PATH) > 0 then
      begin
        Msg.Result := 0;
        s.Add(CFileName);
      end;
   if Assigned(FOnDropFile) then FOnDropFile(Self,s);
  finally
    DragFinish(Msg.Drop);
    s.free;
   IsBreak:=True; //DragFinishしたので複数のコンポで共有は出来ない
  end;
end;
{メッセージ処理の開始}
procedure TDropFiles.Connect(Window:THandle);
begin
 inherited  Connect(Window);   {開始}
 DragAcceptFiles(WHandle, True);
 FEnable:=True;
end;
{メッセージ処理の終了}
procedure TDropFiles.DisConnect;
begin
 FEnable:=False;
  DragAcceptFiles(WHandle, False);
 inherited  DisConnect;        {終了}
end;


procedure TDropFiles.Loaded;
begin
  inherited Loaded;
  if  Not(csDesigning in ComponentState) then
  if FEnable then   SetEnable(FEnable);
end;
destructor TDropFiles.Destroy;
begin
   DragAcceptFiles(WHandle, False);
  inherited Destroy;
end;
procedure TDropFiles.SetParent(s:TWinControl);
begin
 if Enable then
  begin
    DisConnect;
    FParent:=s;
    if assigned(FParent) Then  Connect(FParent.Handle);
  end else  FParent:=s;
end;

procedure TDropFiles.SetEnable(f:Boolean);
begin
 if f then begin
    if assigned(FParent) Then  Connect(FParent.Handle);
 end else  DisConnect;
 FEnable:=f;
end;
procedure Register;
begin
  RegisterComponents('Samples', [TDropFiles]);
end;
end.

Original document by 裏目小僧        氏 ID:(GGA03463)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。