捐赠 | 广告 | 注册 | 发布 | 上传 | 关于我们    
  沪ICP备05001939号 DELPHI盒子 | 盒子论坛 | 盒子文章 | 盒子问答悬赏 | 最新更新 | 论坛检索 | 下载中心 | 高级搜索    
  精品专区 | 繁體中文 | 奖励公告栏 | 直通车账号登陆 | 关闭GOOGLE广告 | 临时留言    
盒子资源分类
全部展开 - 全部合拢
让程序支持外来文本拖放的单元文件
关键字：uDragDropOLE Shell 拖放文本
来　自：原创
平　台：Win2k/XP/NT,Win2003 下载所需：0 火柴
深浅度：中级 完成时间：2007/11/1
发布者：senfore 发布时间：2007/11/1
编辑器：DELPHI7 语　　种：简体中文
分　类：不常用 下载浏览：0/10079
加入到我的收藏
下载错误报错
登陆以后才能下载
 用户名：
 密　码：
自动登陆(30天有效)
无图片
unit uDragDropOLE;

{单元名称：uDragDropOLE
 单元说明：让TwinControl控件能接收外来的文本拖放
 其它声明：senfore收集修改,盒子首发：www.2ccc.com}

interface

uses ActiveX, Types, Classes, ComObj, Windows;

type

  TShellDragEvent = procedure(Sender: Tobject; DragText: string) of object;
  TDragAndDropOLE = class(TObject, IUnknown, IDropTarget)
  private
    FOwnerHandle: Thandle;
    CanDrop: HResult;
    fe: TFormatEtc;
    FRefCount: integer; 
    FOnShellDragDrop: TShellDragEvent;
    procedure SetOnShellDragDrop(const Value: TShellDragEvent);
  protected
   { Iunkown }
    function _AddRef: integer; stdcall;
    function _Release: integer; stdcall;
    function QueryInterface(const IID: TGUID; out Obj): HResult; 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;
  protected
    procedure DoShellDragDrop(DragText: string);
  published
    property OnShellDragDrop: TShellDragEvent read FOnShellDragDrop write SetOnShellDragDrop;
  public
    constructor Create(Aowner: Tcomponent);
    destructor Destroy; override;
  end; 


implementation

uses Controls, SysUtils, Messages;

{ TDragAndDropOLE }

constructor TDragAndDropOLE.Create(Aowner: Tcomponent);
begin
  FRefCount := 0;
  if not (Aowner is Twincontrol) then
  begin
    raise Exception.Create('The DragAndDropOLE''s Owner must be a TWinControl');
  end;
  FOwnerHandle := Twincontrol(Aowner).handle;
  RegisterDragDrop(FOwnerHandle, self);
end;

destructor TDragAndDropOLE.Destroy;
begin
  RevokeDragDrop(FOwnerHandle);
  inherited;
end;

procedure TDragAndDropOLE.DoShellDragDrop(DragText: string);
begin
  if Assigned(fonshellDragDrop) then
    fonshellDragDrop(Self, DragText);
end;

function TDragAndDropOLE.DragEnter(const dataObj: IDataObject;
  grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult;
begin
  result := E_FAIL;
  CanDrop := E_Fail;
  if assigned(dataObj) then
  begin
    with fe do
    begin
      cfFormat := CF_TEXT;
      ptd := nil;
      dwAspect := DVASPECT_CONTENT;
      lindex := -1;
      tymed := TYMED_HGLOBAL;
    end; 
    CanDrop := dataObj.QueryGetData(fe);
    result := CanDrop;
    if not Failed(result) then
      dwEffect := DROPEFFECT_COPY
    else dwEffect := DROPEFFECT_NONE;

  end;
end;

function TDragAndDropOLE.DragLeave: HResult;
begin
  result := S_OK;
end;

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

function TDragAndDropOLE.Drop(const dataObj: IDataObject; grfKeyState: Integer;
  pt: TPoint; var dwEffect: Integer): HResult;
var
  medium: stgMedium;
  hData: HGLOBAL;
begin
  result := E_Fail;
  if not Failed(CanDrop) then
  begin
    result := dataObj.GetData(fe, medium);
    hData := HGLOBAL(GlobalLock(medium.hGlobal));
    DoShellDragDrop(StrPas(pchar(hData)));
    GlobalUnlock(hData);
    GlobalFree(hData); 
  end;
end;

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

procedure TDragAndDropOLE.SetOnShellDragDrop(const Value: TShellDragEvent);
begin
  FOnShellDragDrop := Value;
end;

function TDragAndDropOLE._AddRef: integer;
begin
  result := InterLockedDecrement(FRefCount);
  if Result = 0 then Destroy;
end;

function TDragAndDropOLE._Release: integer;
begin
  result := InterLockedIncrement(FRefCount);
end;

end.

示例：这里给出了使用uDragDropOLE的关键代码。

interface
uses uDragDropOLE;

type
  TDlgDragDrop = class(TForm)
   ...
   procedure FormCreate(Sender: TObject);
   procedure FormDestroy(Sender: TObject);
  private
   DragAndDropOLE:TDragAndDropOLE;
   procedure DropText(Sender: Tobject; DragText: string);
  end;

implementation

procedure TDlgDragDrop.FormCreate(Sender: TObject);
begin
  OleInitialize(nil);
  DragAndDropOLE:=TDragAndDropOLE.Create(self);
  DragAndDropOLE.OnShellDragDrop:=DropText;
end;

procedure TDlgDragDrop.FormDestroy(Sender: TObject);
begin
  DragAndDropOLE.Free;
  OleUninitialize;
end;

procedure TDlgDragDrop.DropText(Sender: Tobject; DragText: string);
begin
  showmessage(DragText);
  //拖放来的文本的具体出来代码
end;
Google
 
本站原创作品，未经作者许可，严禁任何方式转载；转载作品，如果侵犯了您的权益，请联系我们！
龙脉加密锁 15元起 Grid++Report 报表 申请支付@网
　相关文章
让程序支持外来文件拖放的单元文件
senfore 2007/11/2 下+0/浏+10577 评+3
让程序支持外来文本拖放的单元文件
senfore 2007/11/1 下+0/浏+10080 评+4
相关评论
共有评论4条 当前显示最后4条评论
senfore 2007/11/2 19:47:33
我晕了，我发布了2个资源阿，这个是拖放文本的处理方法，还有一个是拖放文件的处理方法，管理员只给通过了一个呢
senfore 2007/11/2 19:54:27
《让程序支持外来文件拖放的单元文件》发到论坛上了，地址：
http://bbs.2ccc.com/topic.asp?topicid=276770
itmes 2008/7/31 10:20:46
FCP_FILEOPEN
fjlfx 2010/3/26 14:25:01
拖放文本没有显示啊，不能拖啊
我要发表评论 查看全部评论
 
  DELPHI盒子版权所有 1999-2023 V4.01 粤ICP备10103342号-1 更新RSS列表