この発言に対し以下のコメントが寄せられています

#00765　ぜえた          さん　RE:ﾌｧｲﾙのﾄﾞﾛｯﾌﾟを受け入れるようにするコ




　こんにちは、ぜえた です。




　フォームにこのコンポーネントを置くとエクスプローラなどから
のファイルのドロップ受け入れて、そのファイル名を取得すること
ができるようになります。

　間違っているところがあると思うのでつっこみよろしくお願いし
ます。＞ＡＬＬ

unit FileAcpt;

interface

uses
  Windows, Messages, Classes, Controls, ActiveX, ShellApi;

type
  TFileDropTarget = class;

  TFileAccepter = class(TComponent)
  private
    FDropTarget: TFileDropTarget;
    FWinControl: TWinControl;
    FOnDropFiles: TNotifyEvent;
    FFileNames: TStrings;
    FEnabled: Boolean;
    procedure SetEnabled(Value: Boolean);
    procedure SetWinControl(Value: TWinControl);
    function RegisterTarget: Boolean;
    procedure RevokeTarget;
    procedure GetInfo(Drop: HDrop);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation);
override;
    procedure DoDropFiles; dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property FileNames: TStrings read FFileNames;
  published
    property Enabled: Boolean read FEnabled write SetEnabled default True;
    property WinControl: TWinControl read FWinControl write SetWinControl;
    property OnDropFiles: TNotifyEvent read FOnDropFiles write FOnDropFiles;
  end;

  TFileDropTarget = class(TInterfacedObject, IDropTarget)
  private
    FFileAccepter: TFileAccepter;
    FAcceptable: Boolean;
  protected
    function DragEnter(const dataObj: IDataObject; grfKeyState: Longint;
      pt: TPoint; var dwEffect: Longint): HResult; stdcall;
    function DragOver(grfKeyState: Longint; pt: TPoint;
      var dwEffect: Longint): HResult; stdcall;
    function DragLeave: HResult; stdcall;
    function Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint;
      var dwEffect: Longint): HResult; stdcall;
  public
    constructor Create(AFileAccepter: TFileAccepter);
  end;

procedure Register;

implementation

{ TFileAccepter }

constructor TFileAccepter.Create(AOwner: TComponent); //override;
begin
  inherited Create(AOwner);
  FFileNames := TStringList.Create;
  FDropTarget := TFileDropTarget.Create(Self);
  FDropTarget._AddRef;
  CoLockObjectExternal(FDropTarget, True, False);
  FEnabled := True;
  if (csDesigning in ComponentState) and (AOwner is TWinControl) then
    FWinControl := TWinControl(AOwner);
end;

destructor TFileAccepter.Destroy; //override;
begin
  SetEnabled(False);
  CoLockObjectExternal(FDropTarget, False, True);
  FDropTarget.Free;
  FFileNames.Free;
  inherited Destroy;
end;

procedure TFileAccepter.Notification(AComponent: TComponent; Operation:
TOperation); //override;
begin
  inherited Notification(AComponent, Operation);
  if (AComponent = FWinControl) and (Operation = opRemove) then
    SetWinControl(nil);
end;

procedure TFileAccepter.SetEnabled(Value: Boolean);
begin
  if FEnabled = Value then Exit;
  FEnabled := Value;
  if FWinControl <> nil then begin
    if FEnabled then
      FEnabled := RegisterTarget
    else
      RevokeTarget;
  end;
end;

procedure TFileAccepter.SetWinControl(Value: TWinControl);
begin
  if FWinControl = Value then Exit;
  if FEnabled then begin
    if FWinControl <> nil then
      RevokeTarget;
    FWinControl := Value;
    if FWinControl <> nil then
      FEnabled := RegisterTarget;
  end else begin
    FWinControl := Value;
  end;
end;

function TFileAccepter.RegisterTarget: Boolean;
begin
  Result := True;
  if csDesigning in ComponentState then Exit;
  Result := RegisterDragDrop(FWinControl.Handle, FDropTarget) = S_OK;
end;

procedure TFileAccepter.RevokeTarget;
begin
  if csDesigning in ComponentState then Exit;
  if not (csDestroying in FWinControl.ComponentState) then
    RevokeDragDrop(FWinControl.Handle);
end;

procedure TFileAccepter.GetInfo(Drop: HDrop);
var
  c: Integer;
  i: Integer;
  Buf: array[0..MAX_PATH - 1] of Char;
begin
  c := DragQueryFile(Drop, $FFFFFFFF, Buf, MAX_PATH);
  FFileNames.Clear;
  FFileNames.Capacity := c;
  for i := 0 to c - 1 do begin
    DragQueryFile(Drop, i, Buf, MAX_PATH);
    FFileNames.Add(Buf);
  end;
end;

procedure TFileAccepter.DoDropFiles; //dynamic;
begin
  if Assigned(FOnDropFiles) then FOnDropFiles(Self);
end;

{ TFileDropTarget }

const
  FormatEtc: TFormatEtc = (
    cfFormat: CF_HDROP;
    ptd: nil;
    dwAspect: DVASPECT_CONTENT;
    lindex: -1;
    tymed: TYMED_HGLOBAL);

constructor TFileDropTarget.Create(AFileAccepter: TFileAccepter);
begin
  inherited Create;
  FFileAccepter := AFileAccepter;
end;

function TFileDropTarget.DragEnter(const dataObj: IDataObject; grfKeyState:
Longint;
  pt: TPoint; var dwEffect: Longint): HResult; stdcall;
begin
  FAcceptable := dataObj.QueryGetData(FormatEtc) = S_OK;
  if FAcceptable then
    dwEffect := DROPEFFECT_COPY
  else
    dwEffect := DROPEFFECT_NONE;
  Result := S_OK;
end;

function TFileDropTarget.DragOver(grfKeyState: Longint; pt: TPoint;
  var dwEffect: Longint): HResult; stdcall;
begin
  if FAcceptable then
    dwEffect := DROPEFFECT_COPY
  else
    dwEffect := DROPEFFECT_NONE;
  Result := S_OK;
end;

function TFileDropTarget.DragLeave: HResult; stdcall;
begin
  Result := S_OK;
end;

function TFileDropTarget.Drop(const dataObj: IDataObject; grfKeyState: Longint;
pt: TPoint;
  var dwEffect: Longint): HResult; stdcall;
var
  Medium: TStgMedium;
begin
  if dataObj.GetData(FormatEtc, Medium) <> S_OK then begin
    Result := E_UNEXPECTED;
    Exit;
  end;
  dwEffect := DROPEFFECT_COPY;
  try
    FFileAccepter.GetInfo(Medium.hGlobal);
    FFileAccepter.DoDropFiles;
  finally
    ReleaseStgMedium(Medium);
  end;
  Result := S_OK;
end;

{ Register }

procedure Register;
begin
  RegisterComponents('Samples', [TFileAccepter]);
end;

{ initialization, finalization }

initialization
  OleInitialize(nil);
finalization
  OleUninitialize;
end.

                                                    ぜえた (QZC05100)

Original document by ぜえた          氏 ID:(QZC05100)

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