dropfile.pas

一套很好用的系统控件： Drag and Drop Component Suite v4.0

unit DropFile;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons, ExtCtrls, FileCtrl, Outline, DirOutln, CommCtrl,
  DropSource, ComCtrls, Grids, DropTarget, ActiveX, ShlObj, ComObj,
  DropPIDLTarget, ImgList;

type

  // This thread is used to watch for and
  // display changes in DirectoryOutline.directory
  TDirectoryThread = class(TThread)
  private
    fListView: TListView;
    fDirectory: string;
    FWakeupEvent: THandle; //Used to signal change of directory or terminating
    FFiles: TStrings;
  protected
    procedure ScanDirectory;
    procedure UpdateListView;
    procedure SetDirectory(Value: string);
    procedure ProcessFilenameChanges(fcHandle: THandle);
  public
    constructor Create(ListView: TListView; Dir: string);
    procedure Execute; override;
    destructor Destroy; override;
    procedure WakeUp;
    property Directory: string read FDirectory write SetDirectory;
  end;


  TFormFile = class(TForm)
    DriveComboBox: TDriveComboBox;
    DirectoryOutline: TDirectoryOutline;
    Memo1: TMemo;
    ListView1: TListView;
    btnClose: TButton;
    StatusBar1: TStatusBar;
    Button1: TButton;
    DropFileTarget1: TDropFileTarget;
    Panel1: TPanel;
    DropSource1: TDropFileSource;
    ImageList1: TImageList;
    DropDummy1: TDropDummy;
    procedure DriveComboBoxChange(Sender: TObject);
    procedure DirectoryOutlineChange(Sender: TObject);
    procedure btnCloseClick(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure ListView1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure ListView1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure DropSource1Feedback(Sender: TObject; Effect: Integer;
      var UseDefaultCursors: Boolean);
    procedure DropFileTarget1Enter(Sender: TObject;
      ShiftState: TShiftState; Point: TPoint; var Effect: Integer);
    procedure DropFileTarget1Drop(Sender: TObject; ShiftState: TShiftState;
      Point: TPoint; var Effect: Integer);
    procedure DropFileTarget1GetDropEffect(Sender: TObject;
      ShiftState: TShiftState; Point: TPoint; var Effect: Integer);
  private
    { Private declarations }
    DragPoint: TPoint;
    SourcePath: string;
    IsEXEfile: boolean;
    DirectoryThread: TDirectoryThread;
  public
    { Public declarations }
  end;

var
  FormFile: TFormFile;

implementation

{$R *.DFM}

//CUSTOM CURSORS:
//The cursors in DropCursors.res are exactly the same as the default cursors.
//Use DropCursors.res as a template if you wish to customise your own cursors.
//For this demo we've created Cursors.res - some coloured cursors.
{$R DropCursors.res}
const
   crCopy = 101; crMove = 102; crLink = 103;
   crCopyScroll = 104; crMoveScroll = 105; crLinkScroll = 106;

//----------------------------------------------------------------------------
// Miscellaneous functions
//----------------------------------------------------------------------------

//******************* AddSlash *************************
function AddSlash(path: string): string;
begin
  if (length(path) = 0) or (path[length(path)]='\') then
    result := path
  else result := path +'\';
end;

//******************* CreateLink *************************
procedure CreateLink(SourceFile, ShortCutName: String);
var
  IUnk: IUnknown;
  ShellLink: IShellLink;
  IPFile: IPersistFile;
  tmpShortCutName: string;
  WideStr: WideString;
  i: integer;
begin
  IUnk := CreateComObject(CLSID_ShellLink);
  ShellLink := IUnk as IShellLink;
  IPFile  := IUnk as IPersistFile;
  with ShellLink do
  begin
    SetPath(PChar(SourceFile));
    SetWorkingDirectory(PChar(ExtractFilePath(SourceFile)));
  end;
  ShortCutName := ChangeFileExt(ShortCutName,'.lnk');
  if fileexists(ShortCutName) then
  begin
    ShortCutName := copy(ShortCutName,1,length(ShortCutName)-4);
    i := 1;
    repeat
      tmpShortCutName := ShortCutName +'(' + inttostr(i)+ ').lnk';
      inc(i);
    until not fileexists(tmpShortCutName);
    WideStr := tmpShortCutName;
  end
  else WideStr := ShortCutName;
  IPFile.Save(PWChar(WideStr),False);
end;

//----------------------------------------------------------------------------
// TFormFile methods
//----------------------------------------------------------------------------

//******************* TFormFile.FormCreate *************************
procedure TFormFile.FormCreate(Sender: TObject);
begin
  DragPoint := point(-1,-1);
  //Register the DropTarget window...
  DropFileTarget1.Register(Listview1);
  //DropFileTarget2 is used just to show a drag image over the form as well as
  //the Listview control, just 'icing on the cake'. Note: no drop is allowed.
  DropDummy1.Register(self);

  //Load custom cursors...
  Screen.cursors[crCopy] := loadcursor(hinstance, 'COPY');
  Screen.cursors[crMove] := loadcursor(hinstance, 'MOVE');
  Screen.cursors[crLink] := loadcursor(hinstance, 'LINK');
  Screen.cursors[crCopyScroll] := loadcursor(hinstance, 'COPYSC');
  Screen.cursors[crMoveScroll] := loadcursor(hinstance, 'MOVESC');
  Screen.cursors[crLinkScroll] := loadcursor(hinstance, 'LINKSC');
end;

//******************* TFormFile.FormDestroy *************************
procedure TFormFile.FormDestroy(Sender: TObject);
begin
  if (DirectoryThread <> nil) then
  begin
    DirectoryThread.Terminate;
    DirectoryThread.WakeUp;
  end;
  //UnRegister the DropTarget window...
  DropFileTarget1.UnRegister;
  DropDummy1.UnRegister;
end;

//******************* TFormFile.Button1Click *************************
procedure TFormFile.btnCloseClick(Sender: TObject);
begin
  close;
end;

//******************* TFormFile.DriveComboBoxChange *************************
procedure TFormFile.DriveComboBoxChange(Sender: TObject);
begin
  DirectoryOutline.Drive := DriveComboBox.Drive;
end;

//******************* TFormFile.DirectoryOutlineChange *************************
procedure TFormFile.DirectoryOutlineChange(Sender: TObject);
begin
  if (DirectoryThread = nil) then
  begin
    DirectoryThread := TDirectoryThread.Create(ListView1, DirectoryOutline.Directory)
  end else
    DirectoryThread.Directory := DirectoryOutline.Directory;
end;

//******************* TFormFile.ListView1MouseDown *************************
procedure TFormFile.ListView1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  DragPoint := Point(X,Y);
end;

//******************* TFormFile.ListView1MouseMove *************************
procedure TFormFile.ListView1MouseMove(Sender: TObject; Shift: TShiftState;
  X, Y: Integer);
var
  i: integer;
  Filename: string;
  Res: TDragResult;
begin

  //Make sure mouse has moved at least 10 pixels before starting drag ...
  if (DragPoint.X = -1) or ((Shift <> [ssLeft]) and (Shift <> [ssRight])) or
     ((abs(DragPoint.X - X) <10) and (abs(DragPoint.Y - Y) <10)) then exit;
  //If no files selected then exit...
  if Listview1.SelCount = 0 then exit;

  Statusbar1.simpletext := '';
  DropSource1.Files.clear;

  //Fill DropSource1.Files with selected files in ListView1
  for i := 0 to Listview1.items.Count-1 do
    if (Listview1.items.item[i].Selected) then
    begin
      Filename :=
        AddSlash(DirectoryOutline.Directory)+Listview1.items.item[i].caption;
      DropSource1.Files.Add(Filename);
    end;

  //--------------------------
    res := DropSource1.execute;
  //--------------------------

  //Note:
  //The target is responsible from this point on
  //for the copying/moving/linking of the file
  //but the target feeds back to the source what
  //(should have) happened via the returned value of Execute.

  //Feedback in Statusbar1 what happened...
  with StatusBar1 do
    case Res of
      drDropCopy: simpletext := 'Copied successfully';
      drDropMove: simpletext := 'Moved successfully';
      drDropLink: simpletext := 'Linked successfully';
      drCancel: simpletext := 'Drop was cancelled';
      drOutMemory: simpletext := 'Drop cancelled - out of memory';
      else simpletext := 'Drop cancelled - unknown reason';
    end;

end;

//Demonstrates CopyToClipboard method...
//******************* TFormFile.Button1Click *************************
procedure TFormFile.Button1Click(Sender: TObject);
var
  i: integer;
  Filename: string;
begin
  if Listview1.selcount = 0 then
  begin
    StatusBar1.simpletext := 'No files have been selected!';
    exit;
  end;

  DropSource1.Files.clear;
  for i := 0 to Listview1.items.Count-1 do
    if (Listview1.items.item[i].Selected) then
    begin
      Filename :=
        AddSlash(DirectoryOutline.Directory)+Listview1.items.item[i].caption;
      DropSource1.Files.Add(Filename);
    end;
//--------------------------
  DropSource1.CopyToClipboard;
//--------------------------
  DropSource1.Files.clear; //added for safety
  StatusBar1.simpletext :=
    format('%d  file(s) copied to clipboard.',[Listview1.selcount]);

end;

//--------------------------
// SOURCE events...
//--------------------------

//******************* TFormFile.DropSource1Feedback *************************
procedure TFormFile.DropSource1Feedback(Sender: TObject; Effect: Integer;
  var UseDefaultCursors: Boolean);
begin
  UseDefaultCursors := false; //We want to use our own.