dropfile.pas

来自「Drag files and Drop to delphi forms 0402」· PAS 代码 · 共 707 行 · 第 1/2 页

//--------------------------
// SOURCE events...
//--------------------------
procedure TFormFile.DropSource1Feedback(Sender: TObject; Effect: Integer;
  var UseDefaultCursors: Boolean);
begin
  UseDefaultCursors := False; // We want to use our own.
  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;

procedure TFormFile.DropSource1AfterDrop(Sender: TObject;
  DragResult: TDragResult; Optimized: Boolean);
var
  i: integer;
begin
  // Delete source files if target performed an unoptimized drag/move
  // operation (target copies files, source deletes them).
  if (DragResult = drDropMove) and (not Optimized) then
    for i := 0 to DropSource1.Files.Count-1 do
      DeleteFile(DropSource1.Files[i]);
end;

procedure TFormFile.DropSource1Paste(Sender: TObject; Action: TDragResult;
  DeleteOnPaste: Boolean);
var
  i: integer;
begin
  StatusBar1.SimpleText := 'Target pasted file(s)';

  // Delete source files if target performed a paste/move operation and
  // requested the source to "Delete on paste".
  if (DeleteOnPaste) then
    for i := 0 to DropSource1.Files.Count-1 do
      DeleteFile(DropSource1.Files[i]);
end;


//--------------------------
// TARGET events...
//--------------------------
procedure TFormFile.DropFileTarget1Enter(Sender: TObject;
  ShiftState: TShiftState; Point: TPoint; var Effect: Integer);
begin
  // Note: GetDataOnEnter has been set to True.
  // A side effect of this is that TDropFileTarget can't be used to accept drops
  // from WinZip. Although the file names are received correctly, the files
  // aren't extracted yet and thus can't be copied/moved.
  // This is caused by a quirk in WinZip; Apparently WinZip doesn't like
  // IDataObject.GetData to be called before IDropTarget.Drop is called.

  // Save the location (path) of the files being dragged.
  // Also flags if an EXE file is being dragged.
  // This info will be used to set the default (ie. no Shift or Ctrl Keys
  // pressed) drag behaviour (COPY, MOVE or LINK).
  if (DropFileTarget1.Files.count > 0) then
  begin
    SourcePath := ExtractFilePath(DropFileTarget1.Files[0]);
    IsEXEfile := (DropFileTarget1.Files.count = 1) and
      (AnsiCompareText(ExtractFileExt(DropFileTarget1.Files[0]), '.exe') = 0);
  end;
end;

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);

  // Filter out the DROPEFFECT_SCROLL flag if set...
  // (ie: when dropping a file while the target window is scrolling)
  Effect := Effect and not DROPEFFECT_SCROLL;
  // Now, 'Effect' should equal one of the following:
  // DROPEFFECT_COPY, DROPEFFECT_MOVE or DROPEFFECT_LINK.
  // Note however, that if we call TDropTarget.PasteFromClipboard, Effect
  // can be a combination of the above drop effects.

  for i := 0 to DropFileTarget1.Files.count-1 do
  begin
    // Name mapping occurs when dragging files from Recycle Bin...
    // In most situations Name Mapping can be ignored entirely.
    if (i < DropFileTarget1.MappedNames.Count) then
      NewFilename := NewPath+DropFileTarget1.MappedNames[i]
    else
      NewFilename := NewPath+ExtractFilename(DropFileTarget1.Files[i]);

    if not FileExists(NewFilename) then
    begin
      if NewFilename = DropFileTarget1.Files[i] then
      begin
        Windows.MessageBox(Handle,
          'The destination folder is the same as the source!',
          'Drag/Drop Demo', mb_iconStop or mb_OK);
        Break;
      end;

      try
        if (Effect and DROPEFFECT_COPY <> 0) then
        begin
          Effect := DROPEFFECT_COPY;
          // Copy the file.
          if CopyFile(PChar(DropFileTarget1.Files[i]), PChar(NewFilename), True) then
            inc(SuccessCnt);
        end else
        if (Effect and DROPEFFECT_MOVE <> 0) then
        begin
          Effect := DROPEFFECT_MOVE;
          // Move the file.
          if RenameFile(DropFileTarget1.Files[i], NewFilename) then
            inc(SuccessCnt)
        end;
      except
        // Ignore errors.
      end;
    end;

    if (Effect and DROPEFFECT_LINK <> 0) then
    begin
      Effect := DROPEFFECT_LINK;
      // Create a shell link to the file.
      CreateLink(DropFileTarget1.Files[i], NewFilename);
      inc(SuccessCnt);
    end;

  end;

  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;

procedure TFormFile.DropFileTarget1GetDropEffect(Sender: TObject;
  ShiftState: TShiftState; Point: TPoint; var Effect: Integer);
var
  Scroll: DWORD;
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...

  // Save the value of the auto scroll flag.
  // As an alternative we could implement our own auto scroll logic here.
  Scroll := DWORD(Effect) and DROPEFFECT_SCROLL;

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

  // Reject the drop if source and target paths are the same (DROPEFFECT_NONE).
  if (AddSlash(DirectoryOutline.Directory) = SourcePath) then
    Effect := DROPEFFECT_NONE
  // else if Ctrl+Shift are pressed then create a link (DROPEFFECT_LINK).
  else if (ShiftState = [ssShift, ssCtrl]) and
    (Effect and DROPEFFECT_LINK <> 0) then Effect := DROPEFFECT_LINK
  // else if Shift is pressed then move (DROPEFFECT_MOVE).
  else if (ShiftState = [ssShift]) and
    (Effect and DROPEFFECT_MOVE<>0) then Effect := DROPEFFECT_MOVE
  // else if Ctrl is pressed then copy (DROPEFFECT_COPY).
  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 (DROPEFFECT_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 (DROPEFFECT_MOVE).
  else if (SourcePath <> '') and (DirectoryOutline.Directory[1] = SourcePath[1]) and
    (Effect and DROPEFFECT_MOVE<>0) then Effect := DROPEFFECT_MOVE
  // otherwise just use whatever we can get away with.
  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;

  // Restore auto scroll flag.
  Effect := Effect or integer(Scroll);
end;

//----------------------------------------------------------------------------
// TDirectoryThread
// This thread monitors the current directory for changes and updates the
// listview whenever the directory is changed (files added, renamed or deleted).
//----------------------------------------------------------------------------

// OK, we're showing off... This is a little overkill for a demo,
// but still you can see what can be done.
constructor TDirectoryThread.Create(ListView: TListView; Dir: string);
begin
  inherited Create(True);

  FListView := ListView;
  Priority := tpLowest;
  FDirectory := Dir;
  FWakeupEvent := Windows.CreateEvent(nil, False, False, nil);
  FFiles := TStringList.Create;

  Resume;
end;

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

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

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

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;

procedure TDirectoryThread.UpdateListView;
var
  NewItem: TListItem;
  i: integer;
begin
  fListView.Items.BeginUpdate;
  try
    fListView.Items.clear;
    for i := 0 to FFiles.Count-1 do
    begin
      NewItem := fListView.Items.Add;
      NewItem.Caption := FFiles[i];
    end;
    if fListView.Items.Count > 0 then
      fListView.ItemFocused := fListView.Items[0];
  finally
    fListView.Items.EndUpdate;
  end;
  FFiles.Clear;
end;

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;

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, PWOHandleArray(@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 {nothing};
      break;
    end;
  end;
end;

end.