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