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

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ShellAPI;

type

TShellDragEvent = procedure(Sender: Tobject; Filename: string) of object;
TDragFromShell = class(Tcomponent)
private
  FOwnerHandle: Thandle;
  FOldAownerWindowProc: Pointer;
  FOnShellDragDrop: TShellDragEvent;
  procedure AownerWindowProc(var Message: TMessage);
  procedure SetOnShellDragDrop(const Value: TShellDragEvent);
protected
  procedure DoShellDragDrop(filename: string);
public
  constructor Create(Aowner: Tcomponent); override;
  destructor Destroy; override;
published
  property OnShellDragDrop: TShellDragEvent read FOnShellDragDrop write SetOnShellDragDrop;
end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Arn:o)', [TDragFromShell]);
end;

{ TDragFromShell }

procedure TDragFromShell.AownerWindowProc(var Message: TMessage);
var
count, index, hdrop: integer;
Pfilename: pchar;
begin
  if Message.MSG <> WM_DROPFILES then
    Message.Result := CallWindowProc(FOldAownerWindowProc, FOwnerHandle, Message.Msg, Message.WPARAM, Message.LPARAM) else
  begin
    Hdrop := message.WParam;
    Getmem(pfilename, Max_path);
    Count := DragQueryfile(hdrop, maxdword, Pfilename, max_path - 1);
    for index := 0 to count - 1 do
    begin
      DragQueryfile(Hdrop, index, Pfilename, maxbyte);
      DoShellDragDrop(StrPas(Pfilename));
    end;
    Freemem(Pfilename);
    Dragfinish(Hdrop);
  end;
end;

constructor TDragFromShell.Create(Aowner: Tcomponent);
begin
  FOldAownerWindowProc := nil;
  if not (Aowner is Twincontrol) then
  begin
    raise Exception.Create('The DragFromShell''s Owner must be a TWinControl');
  end;
  inherited;
  FOwnerHandle := Twincontrol(Aowner).handle;
  DragAcceptFiles(FOwnerHandle, true);
  FOldAownerWindowProc := Pointer(GetWindowLong(FOwnerHandle, GWL_WNDPROC));
  SetWindowLong(FOwnerHandle, GWL_WNDPROC, integer(MakeObjectInstance(AownerWindowProc)));
end;

destructor TDragFromShell.Destroy;
begin
  DragAcceptFiles(FOwnerHandle, false);
  SetWindowLong(FOwnerHandle, GWL_WNDPROC, Integer(FOldAownerWindowProc));
  inherited;
end;

procedure TDragFromShell.DoShellDragDrop(filename: string);
begin
  if Assigned(fonshellDragDrop) then
    fonshellDragDrop(Self, Filename);
end;

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

end.

示例:这里给出了使用uDragFromShell的关键代码。

interface
uses uDragFromShell;

type
TDlgDragDrop = class(TForm)
...
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
  DragFromShell:TDragFromShell;
  procedure DropFiles(Sender: Tobject; Filename: string);
end;

implementation

procedure TDlgDragDrop.FormCreate(Sender: TObject);
begin
  DragFromShell:=TDragFromShell.Create(self);
  DragFromShell.OnShellDragDrop:=DropFiles;
end;

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

procedure TDlgDragDrop.DropFiles(Sender: Tobject; Filename: string);
begin
  SendMessage(application.MainForm.Handle, FCP_FILEOPEN, 0, Integer(Filename));
  //这里是拖放文件的具体处理代码
end;
Google
 
本站原创作品,未经作者许可,严禁任何方式转载;转载作品,如果侵犯了您的权益,请联系我们
龙脉加密锁 15元起 Grid++Report 报表 申请支付@网
 相关文章
让程序支持外来文件拖放的单元文件
senfore 2007/11/2 下+0/浏+7856 评+3
让程序支持外来文本拖放的单元文件
senfore 2007/11/1 下+0/浏+7095 评+4
相关评论
共有评论3条 当前显示最后3条评论
starsoul 2008/3/23 16:51:52
FCP_FILEOPEN没有定义.
如果有两个Edit控件,怎样把文件拖到这两个控件里?
hujiacheng 2010/1/1 15:19:34
http://hi.baidu.com/hellowzr/blog/item/c333fe3c9b0b5ce73c6d9715.html
看下别人的分析吧 。
cmd9x 2015/7/28 16:28:21
Win7以后的带UAC该单元无法使用,需要加上消息过滤:
TChangeWindowMessage = function(message: UInt; dwFlag: DWORD): Bool; stdcall;
const
  MSGFLT_ADD = 1;
  MSGFLT_REMOVE = 2;
//私有成员
    FDLL: HMODULE;
    FCWM: TChangeWindowMessage;//过滤并允许UAC下拖放消息
//实现
  FDLL := LoadLibrary('User32.dll');
  if (FDLL <> 0) then
  begin
    @FCWM := GetProcAddress(FDLL, 'ChangeWindowMessageFilter');
    if @FCWM <> nil then
    begin
      FCWM($0049, MSGFLT_ADD);
      FCWM(WM_DROPFILES, MSGFLT_ADD);
    end;
  end;
我要发表评论 查看全部评论
 
  DELPHI盒子版权所有 1999-2012 V3.01 沪ICP备05001939号 更新RSS列表