dropfile.pas

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

  case DWORD(Effect) of
    DROPEFFECT_COPY: Windows.SetCursor(Screen.Cursors[crCopy]);
    DROPEFFECT_MOVE: Windows.SetCursor(Screen.Cursors[crMove]);
    DROPEFFECT_LINK: Windows.SetCursor(Screen.Cursors[crLink]);
    DROPEFFECT_SCROLL OR DROPEFFECT_COPY:
      Windows.SetCursor(Screen.Cursors[crCopyScroll]);
    DROPEFFECT_SCROLL OR DROPEFFECT_MOVE:
      Windows.SetCursor(Screen.Cursors[crMoveScroll]);
    DROPEFFECT_SCROLL OR DROPEFFECT_LINK:
      Windows.SetCursor(Screen.Cursors[crLinkScroll]);
  else UseDefaultCursors := true; //Use default NoDrop
  end;

end;

//--------------------------
// TARGET events...
//--------------------------

//******************* TFormFile.DropFileTarget1Enter *************************
procedure TFormFile.DropFileTarget1Enter(Sender: TObject;
  ShiftState: TShiftState; Point: TPoint; var Effect: Integer);
begin
  //Note: GetDataOnEnter = true ...
  //saves the location (path) of the files being dragged.
  //Also flags if an EXE file.
  //This info will be used to set the default (ie. no Shift or Ctrl Keys pressed)
  //drag behaviour, whether COPY, MOVE or LINK
  if (DropFileTarget1.Files.count > 0) then
  begin
    SourcePath := extractfilepath(DropFileTarget1.Files[0]);
    if (DropFileTarget1.Files.count = 1) and
         (lowercase(extractfileext(DropFileTarget1.Files[0])) ='.exe') then
      IsEXEfile := true else 
      IsEXEfile := false;
  end;
end;

//******************* TFormFile.DropFileTarget1Drop *************************
procedure TFormFile.DropFileTarget1Drop(Sender: TObject;
  ShiftState: TShiftState; Point: TPoint; var Effect: Integer);
var
  i, SuccessCnt: integer;
  NewFilename: string;
  newPath: string;
begin
  SuccessCnt := 0;
  NewPath := AddSlash(DirectoryOutline.Directory);
  with DropFileTarget1 do
  begin
    for i := 0 to Files.count-1 do
    begin
      NewFilename := NewPath+ExtractFilename(Files[i]);

      if (Effect = DROPEFFECT_LINK) then
      begin
        CreateLink(Files[i], NewFilename);
        inc(SuccessCnt);
        continue;
      end;

      if NewFilename = Files[i] then
      begin
        windows.messagebox(handle,
          'The destination folder is the same as the source!',
          'DropSource Demo', mb_iconStop or mb_OK);
        Break;
      end;
      if not fileexists(NewFilename) then
        try
          if (Effect = DROPEFFECT_MOVE) and
              renamefile(Files[i],NewFilename) then
            inc(SuccessCnt)
          else if (Effect = DROPEFFECT_COPY) and
                    copyfile(PChar(Files[i]),PChar(NewFilename),true) then
            inc(SuccessCnt);
        except
        end;
    end; {for loop}

    if (Effect = DROPEFFECT_MOVE) then
      StatusBar1.simpletext :=
        format('%d file(s) were moved.   Files dropped at point (%d,%d).',
          [SuccessCnt, Point.x,Point.y])
    else if (Effect = DROPEFFECT_COPY) then
      StatusBar1.simpletext :=
        format('%d file(s) were copied.   Files dropped at point (%d,%d).',
          [SuccessCnt, Point.x,Point.y])
    else
      StatusBar1.simpletext :=
        format('%d file(s) were linked.   Files dropped at point (%d,%d).',
          [SuccessCnt, Point.x,Point.y]);
  end;
end;

//******************* TFormFile.DropFileTarget1GetDropEffect *************************
procedure TFormFile.DropFileTarget1GetDropEffect(Sender: TObject;
  ShiftState: TShiftState; Point: TPoint; var Effect: Integer);
begin
  //Note: The 'Effect' parameter (on event entry) is the
  //set of effects allowed by both the source and target.
  //Use this event when you wish to override the Default behaviour...

  //We're only interested in ssShift & ssCtrl here so
  //mouse buttons states are screened out ...
  ShiftState := ([ssShift, ssCtrl] * ShiftState);

  //if source and target paths are the same then DROPEFFECT_NONE
  if (AddSlash(DirectoryOutline.Directory) = SourcePath) then
    Effect := DROPEFFECT_NONE
  //else if Ctrl+Shift...
  else if (ShiftState = [ssShift, ssCtrl]) and
    (Effect and DROPEFFECT_LINK<>0) then Effect := DROPEFFECT_LINK
  //else if Shift...
  else if (ShiftState = [ssShift]) and
    (Effect and DROPEFFECT_MOVE<>0) then Effect := DROPEFFECT_MOVE
  //else if Ctrl...
  else if (ShiftState = [ssCtrl]) and
    (Effect and DROPEFFECT_COPY<>0) then Effect := DROPEFFECT_COPY
  //else if dragging a single EXE file then default to LINK ...
  else if IsEXEfile and (Effect and DROPEFFECT_LINK<>0) then
    Effect := DROPEFFECT_LINK
  //else if source and target drives are the same then default to MOVE
  else if (SourcePath <> '') and (DirectoryOutline.Directory[1] = SourcePath[1]) and
    (Effect and DROPEFFECT_MOVE<>0) then Effect := DROPEFFECT_MOVE
  else if (Effect and DROPEFFECT_COPY<>0) then Effect := DROPEFFECT_COPY
  else if (Effect and DROPEFFECT_MOVE<>0) then Effect := DROPEFFECT_MOVE
  else if (Effect and DROPEFFECT_LINK<>0) then Effect := DROPEFFECT_LINK
  else Effect := DROPEFFECT_NONE;

  //Adding DROPEFFECT_SCROLL to Effect will now
  //automatically scroll the target window.
  if (Point.Y < 15) or (Point.Y > Listview1.clientheight-15) then
    Effect := Effect or integer(DROPEFFECT_SCROLL);
end;

//----------------------------------------------------------------------------
// TDirectoryThread methods
//----------------------------------------------------------------------------

//OK, we're showing off ... it's a little fiddly for a demo ...
//but still you can see what can be done.

//******************* TDirectoryThread.Create *************************
constructor TDirectoryThread.Create(ListView: TListView; Dir: string);
begin
  inherited Create(True);

  fListView := ListView;
  FreeOnTerminate := true;
  Priority := tpLowest;
  fDirectory := Dir;
  FWakeupEvent := windows.CreateEvent(nil, False, False, nil);
  FFiles := TStringList.Create;

  Resume;
end;

//******************* TDirectoryThread.Destroy *************************
destructor TDirectoryThread.Destroy;
begin
  CloseHandle(FWakeupEvent);
  FFiles.Free;
  inherited Destroy;
end;

//******************* TDirectoryThread.WakeUp *************************
procedure TDirectoryThread.WakeUp;
begin
  SetEvent(FWakeupEvent);
end;

//******************* TDirectoryThread.SetDirectory *************************
procedure TDirectoryThread.SetDirectory(Value: string);
begin
  if (Value = FDirectory) then
    exit;
  FDirectory := Value;
  WakeUp;
end;

//******************* TWaitThread.ScanDirectory *************************
procedure TDirectoryThread.ScanDirectory;
var
  sr: TSearchRec;
  res: integer;
begin
  FFiles.Clear;
  res := FindFirst(AddSlash(fDirectory)+'*.*', 0, sr);
  try
    while (res = 0) and (not Terminated) do
    begin
      if (sr.name <> '.') and (sr.name <> '..') then
        FFiles.Add(lowercase(sr.name));
      res := FindNext(sr);
    end;
  finally
    FindClose(sr);
  end;
end;

//******************* TDirectoryThread.UpdateListView *************************
procedure TDirectoryThread.UpdateListView;
var
  NewItem : TListItem;
  i: integer;
begin
  with fListView.items do
  begin
    beginupdate;
    clear;
    for i := 0 to FFiles.Count-1 do
    begin
      NewItem := Add;
      NewItem.Caption := FFiles[i];
    end;
    if count > 0 then fListView.itemfocused := item[0];
    endupdate;
  end;
  FFiles.Clear;
end;

//******************* TWaitThread.Execute *************************
procedure TDirectoryThread.Execute;
var
  fFileChangeHandle : THandle;
begin

  //OUTER LOOP - which will exit only when terminated ...
  //  directory changes will be processed within this OUTER loop
  //  (file changes will be processed within the INNER loop)
  while (not Terminated) do
  begin
    ScanDirectory;
    Synchronize(UpdateListView);

    //Monitor directory for file changes
    fFileChangeHandle :=
      FindFirstChangeNotification(PChar(fDirectory), false, FILE_NOTIFY_CHANGE_FILE_NAME);
    if (fFileChangeHandle = INVALID_HANDLE_VALUE) then
      //Can't monitor filename changes! Just wait for change of directory or terminate
      WaitForSingleObject(FWakeupEvent, INFINITE)
    else
      try
        //This function performs an INNER loop...
        ProcessFilenameChanges(fFileChangeHandle);
      finally
        FindCloseChangeNotification(fFileChangeHandle);
      end;
  end;
end;

//******************* TWaitThread.ProcessFilenameChanges *************************
procedure TDirectoryThread.ProcessFilenameChanges(fcHandle: THandle);
var
  WaitResult : DWORD;
  HandleArray : array[0..1] of THandle;
begin
  HandleArray[0] := FWakeupEvent;
  HandleArray[1] := fcHandle;
  //INNER LOOP -
  //  which will exit only if terminated or the directory is changed
  //  filename changes will be processed within this loop
  while (not Terminated) do
  begin
    //wait for either filename or directory change, or terminate...
    WaitResult := WaitForMultipleObjects(2, @HandleArray, False, INFINITE);

    if (WaitResult = WAIT_OBJECT_0 + 1) then //filename has changed
    begin
      repeat //collect all immediate filename changes...
        FindNextChangeNotification(fcHandle);
      until Terminated or (WaitForSingleObject(fcHandle, 0) <> WAIT_OBJECT_0);
      if Terminated then break;
      //OK, now update (before restarting inner loop)...
      ScanDirectory;
      Synchronize(UpdateListView);
    end else
    begin // Either directory changed or terminated ...
      //collect all (almost) immediate directory changes before exiting...
      while (not Terminated) and
        (WaitForSingleObject(FWakeupEvent, 100) = WAIT_OBJECT_0) do;
      break;
    end;
  end;
end;

end.