unit FEILView; // FileExportImporListView
 
interface 
 
uses 
  Windows, Sysutils, Messages, Classes, Controls, Forms, ActiveX, 
  ComCtrls, Shlobj, Comobj, ShellApi, FileCtrl; 
 
type 
  TFEILView = class(TListView, IDropSource) 
  private 
    FDir: string; 
    FStart: TPoint; 
    FListitem: TListItem; 
    FDiff: Integer; 
  protected 
    procedure einlesen; 
    procedure setdir(s: string); 
    function GetFileListDataObject(const FLR: string; 
      Files: TStrings): IDataObject; 
    procedure MouseDown(Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); override; 
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; 
  public 
    procedure wmdropfiles(var msg: TMessage); message wm_dropfiles; 
    procedure loaded; override; 
    constructor Create(Owner: TComponent); override; 
    function QueryContinueDrag(fEscapePressed: BOOL; 
      grfKeyState: Longint): HResult; stdcall; 
    function GiveFeedback(dwEffect: Longint): HResult; stdcall; 
  published 
    property Directory: string read FDir write setdir; 
    property Threshold: Integer read FDiff write FDiff; 
  end; 
 
procedure Register; 
 
implementation 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TFEILView]); 
end; 
 
procedure TFEILView.loaded; 
begin 
  inherited; 
  dragacceptfiles(handle, true); 
  einlesen; 
end; 
 
constructor TFEILView.Create(Owner: TComponent); 
begin 
  inherited Create(Owner); 
  Multiselect := true; 
  Rowselect := false; // wichtig 
  FDiff := 4; 
  OleInitialize(nil); 
end; 
 
procedure TFEILView.MouseDown(Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  if Button = mbLeft then begin 
    FStart.x := X; 
    FStart.y := Y; 
  end; 
  inherited; 
end; 
 
procedure TFEILView.MouseMove(Shift: TShiftState; X, 
  Y: Integer); 
var 
  sl: TStringList; 
  i: Integer; 
  dto: IDataObject; 
  dwEffect: Longint; 
begin 
  inherited; 
  if (SelCount > 0) and (csLButtonDown in ControlState) 
    and ((Abs(X - FStart.x) >= FDiff) 
    or (Abs(Y - FStart.y) >= FDiff)) 
    then begin 
    sendmessage(handle, WM_LBUTTONUP, 0, MakeLong(X, Y)); 
    sl := TStringList.Create; 
    try 
      sl.Capacity := SelCount; 
      for i := 0 to Items.Count - 1 do 
        if Items[i].selected then sl.add(Items[i].caption); 
      dto := GetFileListDataObject(FDir, sl); 
    finally 
      sl.Free; 
    end; 
    dwEffect := 0; 
    DoDragDrop(dto, Self, DROPEFFECT_COPY, dwEffect); 
  end; 
end; 
 
function TFEILView.GetFileListDataObject(const FLR: string; Files: TStrings): 
  IDataObject; 
type 
  PIILArray = array[0..0] of PItemIDList; 
  PAoPIIL = ^PIILArray; 
var 
  Malloc: IMalloc; 
  Root, Folder: IShellFolder; 
  lg, dwAttributes: ULONG; 
  FolderPidl: PItemIDList; 
  p: PAoPIIL; 
  i: Integer; 
begin 
  Result := nil; 
  if Files.Count = 0 then exit; 
  OleCheck(SHGetMalloc(Malloc)); 
  OleCheck(SHGetDesktopFolder(Root)); 
  OleCheck(Root.ParseDisplayName(0, nil, 
    PWideChar(WideString(FLR)), 
    lg, FolderPidl, dwAttributes)); 
  try 
    OleCheck(Root.BindToObject(FolderPidl, nil, IShellFolder, 
      Pointer(Folder))); 
    p := AllocMem(SizeOf(PItemIDList) * Files.Count); 
    try 
      for i := 0 to Files.Count - 1 do 
      begin 
        OleCheck(Folder.ParseDisplayName(0, nil, 
          PWideChar(WideString(Files[i])), lg, p^[i], 
          dwAttributes)); 
      end; 
      OleCheck(Folder.GetUIObjectOf(0, Files.Count, p^[0], IDataObject, 
        nil, 
        Pointer(Result))); 
    finally 
      for i := 0 to Files.Count - 1 do begin 
        if p^[i] <> nil then Malloc.Free(p^[i]); 
      end; 
      FreeMem(p); 
    end; 
  finally 
    Malloc.Free(FolderPidl); 
  end; 
end; 
 
function TFEILView.QueryContinueDrag(fEscapePressed: BOOL; 
  grfKeyState: Longint): HResult; stdcall; 
begin 
  if (grfKeyState and MK_RBUTTON = 2) or fEscapePressed then 
  begin 
    Result := DRAGDROP_S_CANCEL 
  end else if grfKeyState and MK_LBUTTON = 0 then 
  begin 
    Result := DRAGDROP_S_DROP 
  end else 
  begin 
    Result := S_OK; 
  end; 
end; 
 
function TFEILView.GiveFeedback(dwEffect: Longint): HResult; stdcall; 
begin 
  Result := DRAGDROP_S_USEDEFAULTCURSORS; 
end; 
 
procedure TFEILView.einlesen; 
var sr: TWin32FindData; 
  h: THandle; 
begin 
  Items.beginupdate; 
  Items.Clear; 
  if DirectoryExists(FDir) then begin 
    h := FindFirstFile(PChar(FDir + '*'), sr); 
    if h <> INVALID_HANDLE_VALUE then repeat 
        if sr.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY = 0 then begin 
          FListitem := Items.add; 
          FListitem.caption := sr.cFileName; 
        end; 
      until Findnextfile(h, sr) = false; 
    windows.FindClose(h); 
  end; 
  Items.endupdate; 
end; 
 
procedure TFEILView.setdir(s: string); 
begin 
  if s = '' then s := '\' else 
    if ansilastchar(s) <> '\' then s := s + '\'; 
  s := AnsiUpperCase(s); 
  if s = FDir then exit; 
  FDir := s; 
  einlesen; 
end; 
 
procedure TFEILView.wmdropfiles(var msg: TMessage); 
var 
  i, len, count: integer; 
  filename, n, k: string; 
begin 
  count := dragqueryfile(msg.wparam, $FFFFFFFF, nil, 0); 
  for i := 0 to count - 1 do begin 
    len := dragqueryfile(msg.wparam, i, nil, 0); 
    setlength(filename, len); 
    dragqueryfile(msg.wparam, i, pchar(filename), len + 1); 
    // ------------------------- Bei Bedarf -------------------------- 
    if AnsiUpperCase(extractfilepath(filename)) = FDir then continue; 
    // --------------------------------------------------------------- 
    n := extractfilename(filename); 
    k := ''; 
    while fileexists(FDir + k + n) do k := k + 'Kopie von '; 
    n := k + n; 
    if copyfile(pchar(filename), pchar(FDir + n), false) 
      then begin 
      FListitem := Items.add; 
      FListitem.caption := n; 
      FListitem.selected := true; 
      FListitem.makevisible(false); 
    end; 
  end; 
end; 
 
end.