注册 登录  
 加关注
   显示下一条  |  关闭
温馨提示!由于新浪微博认证机制调整,您的新浪微博帐号绑定已过期,请重新绑定!立即重新绑定新浪微博》  |  关闭

BCB-DG's Blog

...

 
 
 

日志

 
 

Delphi將文件從TFileListBox拖曳到Explorer  

2013-07-25 14:39:31|  分类: Delphi |  标签: |举报 |字号 订阅

  下载LOFTER 我的照片书  |
//轉

unit Main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls, FileCtrl, ActiveX, ShlObj, ComObj;

type
  TfrmMain = class(TForm, IDropSource)
    pnl1: TPanel;
    pnl2: TPanel;
    dcb1: TDriveComboBox;
    dl1: TDirectoryListBox;
    fl1: TFileListBox;
    sp1: TSplitter;
    procedure fl1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure fl1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
  private
    FPos: TPoint;
    function QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: Longint): HResult; stdcall;
    function GiveFeedback(dwEffect: Longint): HResult; stdcall;
  public
  end;

var
  frmMain: TfrmMain;

implementation  
{$R *.dfm}

function GetObject(Directory: string; sl: TStrings): IDataObject;
type
  PArrayOfPItemIDList = ^TArrayOfPItemIDList;
  TArrayOfPItemIDList = array[0..0] of PItemIDList;
var
  Malloc: IMalloc;
  Root: IShellFolder;
  FolderPidl: PItemIDList;
  Folder: IShellFolder;
  p: PArrayOfPItemIDList;
  chEaten: ULONG;
  dwAttributes: ULONG;
  FileCount: Integer;
  i: Integer;
begin
  Result := nil;
  if (sl.Count < 1) then Exit;
  OleCheck(SHGetMalloc(Malloc));
  OleCheck(SHGetDesktopFolder(Root));
  OleCheck(Root.ParseDisplayName(0, nil, PWideChar(WideString(Directory)), chEaten, FolderPidl, dwAttributes));
  try
    OleCheck(Root.BindToObject(FolderPidl, nil, IShellFolder, Pointer(Folder)));
    FileCount := sl.Count;
    p := AllocMem(SizeOf(PItemIDList) * FileCount);
    try
      for i := 0 to FileCount - 1 do
        OleCheck(Folder.ParseDisplayName(0, nil, PWideChar(WideString(sl[i])), chEaten, p^[i], dwAttributes));
      OleCheck(Folder.GetUIObjectOf(0, FileCount, p^[0], IDataObject, nil, Pointer(Result)));
    finally
      for i := 0 to FileCount - 1 do
        if (p^[i] <> nil) then Malloc.Free(p^[i]);
      FreeMem(p);
    end;
  finally
    Malloc.Free(FolderPidl);
  end;
end;

function TfrmMain.QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: Longint): HResult; stdcall;
begin
  if fEscapePressed or (grfKeyState and MK_RBUTTON = MK_RBUTTON) then
    Result := DRAGDROP_S_CANCEL
  else if (grfKeyState and MK_LBUTTON = 0) then
    Result := DRAGDROP_S_DROP
  else
    Result := S_OK;
end;

function TfrmMain.GiveFeedback(dwEffect: Longint): HResult; stdcall;
begin
  Result := DRAGDROP_S_USEDEFAULTCURSORS;
end;

procedure TfrmMain.fl1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then
  begin
    FPos.X := X;
    FPos.Y := Y;
  end;
end;

procedure TfrmMain.fl1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
  sl: TStringList;
  i: Integer;
  obj: IDataObject;
  eft: Integer;
begin
  with Sender as TFileListBox do
  if (SelCount > 0) and (csLButtonDown in ControlState) and ((Abs(X - FPos.X) >= 5) or (Abs(Y - FPos.Y) >= 5)) then
  begin
    Perform(WM_LBUTTONUP, 0, MakeLong(X, Y));
    sl := TStringList.Create;
    try
      sl.Capacity := SelCount;
      for i := 0 to Items.Count - 1 do
        if Selected[i] then sl.Add(Items[i]);
      obj := GetObject(Directory, sl);
    finally
      sl.Free;
    end;
    eft := DROPEFFECT_NONE;
    DoDragDrop(obj, Self, DROPEFFECT_COPY, eft);
  end;
end;

initialization
  OleInitialize(nil);
 
finalization
  OleUninitialize;
 
end.
  评论这张
 
阅读(707)| 评论(0)
推荐 转载

历史上的今天

评论

<#--最新日志,群博日志--> <#--推荐日志--> <#--引用记录--> <#--博主推荐--> <#--随机阅读--> <#--首页推荐--> <#--历史上的今天--> <#--被推荐日志--> <#--上一篇,下一篇--> <#-- 热度 --> <#-- 网易新闻广告 --> <#--右边模块结构--> <#--评论模块结构--> <#--引用模块结构--> <#--博主发起的投票-->
 
 
 
 
 
 
 
 
 
 
 
 
 
 

页脚

网易公司版权所有 ©1997-2017