一个能接受外部拖拽的控件(文字或文件)

恩....也是这2天写的一个小东西的需求, 可以拖拽外部文本文件, 或者选择的一段文本到Memo里显示

查了一下资料, 主要从2个方面实现:

　　1.拖拽文件实现WM_DROPFILES就可以了

　　2.拖拽文本需要实现IDropTarget接口

针对这个功能, 重新封装了一个Memo出来:

  TDropMemo = class(TMemo, IUnknown, IDropTarget)
  private
    FDropAccept: Boolean;
    FDTDropAccept: HResult;
    FFE: TFormatEtc;
    FRefCount: Integer;
  protected
    procedure WMDropFiles(var Msg: TWMDropFiles); message WM_DROPFILES;
    procedure SetDropAccept(const Value: Boolean);
    {IUnknown}
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    {IDropTarget}
    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
    property DropAccept: Boolean read FDropAccept write SetDropAccept;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

//--------------------------------------------------

{ TDragMemo }

constructor TDropMemo.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FRefCount := 0;
end;

destructor TDropMemo.Destroy;
begin
  inherited;
end;

function TDropMemo.DragEnter(const dataObj: IDataObject; grfKeyState: Integer; pt: TPoint;
  var dwEffect: Integer): HResult;
begin
  Result := E_FAIL;
  FDTDropAccept := E_FAIL;

  if not FDropAccept then
    Exit;

  if not Assigned(dataObj) then
    Exit;

  with FFE do
  begin
{$IFDEF UNICODE}
    cfFormat := CF_UNICODETEXT;
{$ELSE}
    cfFormat := CF_TEXT;
{$ENDIF}
    ptd := nil;
    dwAspect := DVASPECT_CONTENT;
    lindex := -1;
    tymed := TYMED_HGLOBAL;
  end;
  FDTDropAccept := dataObj.QueryGetData(FFE);
  Result := FDTDropAccept;
  if not FAILED(Result) then
    dwEffect := DROPEFFECT_COPY
  else
    dwEffect := DROPEFFECT_NONE;
end;

function TDropMemo.DragLeave: HResult;
begin
  Result := S_OK;
end;

function TDropMemo.DragOver(grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult;
begin
  Result := S_OK;
end;

function TDropMemo.Drop(const dataObj: IDataObject; grfKeyState: Integer; pt: TPoint;
  var dwEffect: Integer): HResult;
var
  nMedium: stgMedium;
  nHData: HGLOBAL;
begin
  Result := E_FAIL;

  if FAILED(FDTDropAccept) then
    Exit;

  Result := dataObj.GetData(FFE, nMedium);
  nHData := HGLOBAL(GlobalLock(nMedium.hGlobal));
  try
    SendMessage(Handle, WM_SETTEXT, 0, nHData);
  finally
    GlobalUnlock(nHData);
    GlobalFree(nHData);
  end;
end;

function TDropMemo.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
    Result := S_OK
  else
    Result := E_NOINTERFACE;
end;

procedure TDropMemo.SetDropAccept(const Value: Boolean);
begin
  FDropAccept := Value;
  DragAcceptFiles(Handle, FDropAccept);
  if FDropAccept then
    RegisterDragDrop(Handle, Self)
  else
    RevokeDragDrop(Handle);
end;

procedure TDropMemo.WMDropFiles(var Msg: TWMDropFiles);
var
  nBuffer: array[0..255] of Char;
  nCount: Integer;
  nFile: string;
begin
  with Msg do
  begin
    nCount := DragQueryFile(Drop, $FFFFFFFF, nBuffer, 1);
    if nCount = 0 then
      Exit;
    DragQueryFile(Drop, 0, nBuffer, SizeOf(nBuffer));
    nFile := nBuffer;
    DragFinish(Drop);
  end;
  Lines.LoadFromFile(nFile);
end;

function TDropMemo._AddRef: Integer;
begin
  Result := InterLockedDecrement(FRefCount);
  if Result = 0 then
    Destroy;
end;

function TDropMemo._Release: Integer;
begin
  Result := InterLockedIncrement(FRefCount);
end;

使用的时候, 通过DropAccept属性控制是否开启过拽支持

这个只是支持拖拽到Memo内, 如果想实现拖拽Memo内容到外部, 还需要再实现IDropSource接口, 因为没需求就懒得做了, 哪位有空闲可以一起实现了

另外, 从网上找了一个别人封装的拖拽控件, 基本可以支持所有文本编辑控件:

  TDropText = class(TObject, IUnknown, IDropTarget)
  private
    FHandle: THandle;
    FCanDrop: HResult;
    FFE: TFormatEtc;
    FRefCount: Integer;
  protected
    {IUnknown}
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    {IDropTarget}
    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(AHandle: THandle);
    destructor Destroy; override;
  end;

//----------------------------------------

function TDropText._AddRef: Integer;
begin
  Result := InterLockedDecrement(FRefCount);
  if Result = 0 then
    Destroy;
end;

function TDropText._Release: Integer;
begin
  Result := InterLockedIncrement(FRefCount);
end;

constructor TDropText.Create(AHandle: THandle);
begin
  FRefCount := 0;
  FHandle := AHandle;
  RegisterDragDrop(FHandle, Self);
end;

destructor TDropText.Destroy;
begin
  RevokeDragDrop(FHandle);
  inherited;
end;

function TDropText.DragEnter(const dataObj: IDataObject;
  grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult;
begin
  Result := E_FAIL;
  FCanDrop := E_FAIL;

  if not Assigned(dataObj) then
    Exit;

  with FFE do
  begin
{$IFDEF UNICODE}
    cfFormat := CF_UNICODETEXT;
{$ELSE}
    cfFormat := CF_TEXT;
{$ENDIF}
    ptd := nil;
    dwAspect := DVASPECT_CONTENT;
    lindex := -1;
    tymed := TYMED_HGLOBAL;
  end;
  FCanDrop := dataObj.QueryGetData(FFE);
  Result := FCanDrop;
  if not FAILED(Result) then
    dwEffect := DROPEFFECT_COPY
  else
    dwEffect := DROPEFFECT_NONE;
end;

function TDropText.DragLeave: HResult;
begin
  Result := S_OK;
end;

function TDropText.DragOver(grfKeyState: Integer; pt: TPoint;
  var dwEffect: Integer): HResult;
begin
  Result := S_OK;
end;

function TDropText.Drop(const dataObj: IDataObject; grfKeyState: Integer;
  pt: TPoint; var dwEffect: Integer): HResult;
var
  nMedium: stgMedium;
  nHData: HGLOBAL;
begin
  Result := E_FAIL;

  if FAILED(FCanDrop) then
    Exit;

  Result := dataObj.GetData(FFE, nMedium);
  nHData := HGLOBAL(GlobalLock(nMedium.hGlobal));
  try
    SendMessage(FHandle, WM_SETTEXT, 0, nHData);
  finally
    GlobalUnlock(nHData);
    GlobalFree(nHData);
  end;
end;

function TDropText.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
    Result := S_OK
  else
    Result := E_NOINTERFACE;
end;

调用方式:

   FDragText:= TDropText.Create(Memo1.Handle);

这样就可以让任何拥有文字编辑功能的控件支持文字拖拽的效果了