Eigenes "Senden an" Popup ausführen / Shell-DropHandler aufrufen / ShellExecute

[Ramschhuber]

Hallo,

ich hab mir ein Suchprogramm gebastelt, das Dateien nach bestimmten Kriterien auf der Festplatte sucht und in einer ListBox auflistet. Klappt wunderbar.

Dann kann ich per Rechtsklick ein Popup aufrufen, das mit den gefundenen Dateien irgendetwas macht (z.B. kopieren, löschen, bearbeiten, ...) Klappt auch noch.

Dann wollte ich das Explorer Kontext-Menü "Senden an" auch noch implementieren.
Hab leider keine (API-/Shell-) Funktion gefunden wie z.B. ShellGetContextMenu('SendTo',MyPopup).
Dann hab ich mir die Popup-Einträge selbst zusammengesucht mit SHGetSpecialFolderLocation(..,CSIDL_SENDTO,..), SHGetPathFromIDList(..), FindFirst, FindNext. Hat auch geklappt.

Jetzt gibt es aber unter dem Systemordner "SendTo" sog. DropHandler (z.B. "Desktop (Verknüpfung erstellen).DeskLink" oder "E-Mail-Empfänger.MAPIMAIL"), die ich nicht wie *.LNK-Dateien mit ShellExecute ansprechen kann. Ich bekomme immer die Fehlermeldung "SE_ERR_NOASSOC".
Beispiel:
ExecResult := ShellExecute(0 , 'open' , PChar('C:\Dokumente und Einstellungen\User\SendTo\E-Mail-Empfänger.MAPIMAIL') , PChar('C:\Temp\Test.exe') , nil , SW_SHOWNORMAL);

Wie kann ich eine beliebige Datei an derartige DropHandler (meistens DLL's) von Delphi aus senden?
Z.B. ShellSendFileToDropHandler('C:\Temp\Test.exe','.MAPIMAIL')

Danke!

[Ramschhuber]

Hihi, hab's selber rausgefunden.
Die entstandene Unit SentTo ist beigefügt, für den, den's interessiert.

Code:

unit SendTo;

interface

uses
  Windows, SysUtils, Forms, Classes, ImgList, ShellAPI, ShlObj, ActiveX, Menus, Registry;



type
  TSendToGetFileList = procedure (Sender: TMenuItem; FileList: TStrings) of object;

  TSendToMenuItem    = class(TMenuItem)
    private
      FTarget        : string;
      FOnGetFileList : TSendToGetFileList;
      class procedure SendToClick (Sender: TObject);
    protected
      property SendToTarget  : string             read FTarget        write FTarget;
      property OnGetFileList : TSendToGetFileList read FOnGetFileList write FOnGetFileList;
    public
      constructor Create(AOwner: TComponent; ATarget: string; AOnGetFileList: TSendToGetFileList); reintroduce;
    end;

procedure SetupSendTo          (List      : TStrings);                                                                overload;
procedure SetupSendTo          (PopupMenu : TPopupMenu; OnGetFileList: TSendToGetFileList; ShowIcons: boolean= true); overload;
procedure SetupSendTo          (MenuItem  : TMenuItem;  OnGetFileList: TSendToGetFileList; ShowIcons: boolean= true); overload;

function  GetSpecialFolder     (FolderID: word = CSIDL_DESKTOP): string;

function  CreateShellImageList (AOwner: TComponent): TCustomImageList;
function  GetShellImageIndex   (const FileName: string): integer;

function  DragDropFileToTarget (const FileName,TargetName: string): boolean;



implementation

const
  SID_IDataObject = '{0000010E-0000-0000-C000-000000000046}';
  SID_IDropTarget = '{00000122-0000-0000-C000-000000000046}';

constructor TSendToMenuItem.Create(AOwner: TComponent; ATarget: string; AOnGetFileList: TSendToGetFileList);
  begin { TSendToMenuItem.Create }
  inherited Create(AOwner);
  FTarget        := ATarget;
  FOnGetFileList := AOnGetFileList;
  end;  { TSendToMenuItem.Create }

class procedure TSendToMenuItem.SendToClick(Sender: TObject);
  var
    fc       : integer;
    FileList : TStrings;
    Item     : TSendToMenuItem;

  begin { TSendToMenuItem.SendToClick }
  if not(Sender is TSendToMenuItem) then exit;
  Item := TSendToMenuItem(Sender);
  if not Assigned(Item.OnGetFileList) or (Item.SendToTarget = '') then exit;

  FileList := TStringList.Create;
  try
    Item.OnGetFileList(TMenuItem(Sender),FileList);
    if FileList.Count > 0 then
      begin
      Application.ProcessMessages;
      for fc := 0 to FileList.Count - 1 do
        DragDropFileToTarget(FileList[fc],Item.SendToTarget);
      end;
  finally
    FileList.Free;
    end;
  end;  { TSendToMenuItem.SendToClick }



function GetSpecialFolder(FolderID: word =CSIDL_DESKTOP): string;
  var
    PIDL  : PItemIDList;
    PPath : array [0..MAX_PATH] of AnsiChar;

  begin { GetSpecialFolder }
  Result := '';
  if SHGetSpecialFolderLocation(0,FolderID,PIDL) = NOERROR then
    try
      if SHGetPathFromIDList(PIDL,PPath) then
        begin
        Result := ExcludeTrailingPathDelimiter(PPath);
        if Result <> '' then
        Result := IncludeTrailingPathDelimiter(Result);
        end;
    finally
      CoTaskMemFree(PIDL);
      end;
  end;  { GetSpecialFolder }

function GetShellImageIndex(const FileName: string): integer;
  var FileInfo: TSHFileInfo;

  begin { GetShellImageIndex }
  if SHGetFileInfo(PChar(FileName),0,FileInfo,SizeOf(FileInfo),SHGFI_SYSICONINDEX or SHGFI_SMALLICON) <> 0 then
    Result := FileInfo.iIcon
  else
    Result := -1;
  end;  { GetShellImageIndex }

function CreateShellImageList(AOwner: TComponent): TCustomImageList;
  var
    ListHandle : cardinal;
    FileInfo   : TShFileInfo;

  begin { CreateShellImageList }
  Result     := TCustomImageList.Create(AOwner);
  ListHandle := SHGetFileInfo('',0,FileInfo,SizeOf(FileInfo),SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
  if ListHandle <> 0 then
    begin
    Result.Handle       := ListHandle;
    Result.ShareImages  := true;
    Result.DrawingStyle := dsTransparent;
    end
  else
    FreeAndNil(Result);
  end;  { CreateShellImageList }



procedure SetupSendTo(List: TStrings);
  var fc1,fc2,min: integer;

  procedure AddToList(Folder,FileName: string);
    var fc: integer;

    begin { AddToList }
    for fc := 0 to List.Count - 1 do
      if UpperCase(ExtractFileName(List[fc])) = UpperCase(FileName) then exit;
    List.AddObject(Folder + FileName,TObject(GetShellImageIndex(Folder + FileName)));
    end;  { AddToList }

  procedure ScanTargets(Folder: string);
    const FileAttrs = faArchive or faReadOnly or faHidden;

    var SR: TSearchRec;

    begin { ScanTargets }
    Folder := ExcludeTrailingPathDelimiter(Folder);
    if UpperCase(ExtractFileName(Folder)) <> 'SENDTO' then exit;
    Folder := IncludeTrailingPathDelimiter(Folder);
    if FindFirst(Folder + '*.*',FileAttrs,SR) = 0 then
      begin
      repeat
        if ((SR.Attr and FileAttrs) = SR.Attr) {and (SR.Size > 0)} then
          AddToList(Folder,SR.Name);
      until FindNext(SR) <> 0;
      FindClose(SR);
      end;
    end;  { ScanTargets }

  begin { SetupSendTo }
  if not Assigned(List) then exit;

  List.BeginUpdate;
  try
    ScanTargets(GetSpecialFolder(CSIDL_SENDTO));
    for fc1 := 0 to List.Count - 2 do
      begin
      min := fc1;
      for fc2 := fc1 + 1 to List.Count - 1 do
        if UpperCase(ExtractFileName(List[fc2])) < UpperCase(ExtractFileName(List[min])) then min := fc2;
      if min <> fc1 then List.Exchange(min,fc1);
      end;
  finally
    List.EndUpdate;
    end;
  end;  { SetupSendTo }

procedure SetupSendTo(PopupMenu: TPopupMenu; OnGetFileList: TSendToGetFileList; ShowIcons: boolean= true);
  begin { SetupSendTo }
  if Assigned(PopupMenu) then SetupSendTo(PopupMenu.Items,OnGetFileList,ShowIcons);
  end;  { SetupSendTo }

procedure SetupSendTo(MenuItem: TMenuItem; OnGetFileList: TSendToGetFileList; ShowIcons: boolean= true);
  var
    fc      : integer;
    List    : TStrings;
    NewItem : TMenuItem;

  begin { SetupSendTo }
  if not Assigned(MenuItem) then exit;

  ShowIcons := ShowIcons and not Assigned(MenuItem.SubMenuImages);
  if ShowIcons then MenuItem.SubMenuImages := CreateShellImageList(MenuItem);
  List := TStringList.Create;
  try
    SetupSendTo(List);
    MenuItem.Clear;
    for fc := 0 to List.Count - 1 do
      begin
      NewItem := TSendToMenuItem.Create(MenuItem,List[fc],OnGetFileList);
      with TSendToMenuItem(NewItem) do
        begin
        Caption      := ChangeFileExt(ExtractFileName(List[fc]),'');
        if ShowIcons then
          ImageIndex := integer(List.Objects[fc]);
        OnClick      := TSendToMenuItem.SendToClick;
        end;
      MenuItem.Add(NewItem);
      end;
  finally
    List.Free;
    end;
  end;  { SetupSendTo }



function GetFileDataObject(const FileName: string): IDataObject;
  var
    GUID_DataObject  : TGUID;
    GUID_ShellFolder : TGUID;
    DesktopFolder    : IShellFolder;
    ParentFolder     : IShellFolder;
    Folder           : string;
    Name             : string;
    PIDL             : PItemIDList;
    Eaten            : cardinal;
    Attr             : cardinal;

  begin { GetFileDataObject }
  Result := nil;

// Intialize IDs
  if CLSIDFromString(SID_IDataObject  , GUID_DataObject ) <> S_OK then exit;
  if CLSIDFromString(SID_IShellFolder , GUID_ShellFolder) <> S_OK then exit;

  Name   := ExtractFileName(FileName);
  Folder := ExtractFilePath(FileName);
  Folder := IncludeTrailingPathDelimiter(Folder);

// Get the parent folder object
  if SHGetDesktopFolder(DesktopFolder) <> NOERROR then exit;

// Get the folder PIDL
  if DesktopFolder.ParseDisplayName(0,nil,StringToOLEStr(PChar(Folder)),Eaten,PIDL,Attr) <> S_OK then exit;
  try
// Get the parent folder object
    if DesktopFolder.BindToObject(PIDL,nil,GUID_ShellFolder,ParentFolder) <> S_OK then exit;
  finally
// Release the folder PIDL
    CoTaskMemFree(PIDL);
    end;

// Get the file PIDL
  if ParentFolder.ParseDisplayName(0,nil,StringToOLEStr(PChar(Name)),Eaten,PIDL,Attr) <> S_OK then exit;
  try
// Get the file data object
    if ParentFolder.GetUIObjectOf(0,1,PIDL,GUID_DataObject,nil,Result) <> S_OK then exit;
  finally
// Release the file PIDL
    CoTaskMemFree(PIDL);
    end;
  end;  { GetFileDataObject }

function DragDropFileToTarget(const FileName,TargetName: string): boolean;
  var
    SID_IDropHandler : string;
    GUID_DropHandler : TGUID;
    GUID_DropTarget  : TGUID;
    DropTarget       : IDropTarget;
    DataObject       : IDataObject;
    DropEffect       : integer;
    ExecResult       : cardinal;
    Reg              : TRegistry;

  begin { DragDropFileToTarget }
  Result := false;
  if not FileExists(FileName) or not FileExists(TargetName) then exit;

  ExecResult := ShellExecute(0,nil{'open'},PChar(TargetName),PChar('"' + FileName + '"'),nil,SW_SHOWNORMAL);
  if ExecResult > 32 then
    begin
    Result := true;
    exit;
    end;
  if ExecResult <> SE_ERR_NOASSOC then exit;

  SID_IDropHandler   := '';
  Reg                := TRegistry.Create(KEY_READ);
  try
    Reg.RootKey      := HKEY_CLASSES_ROOT;
    Reg.OpenKeyReadOnly(ExtractFileExt(TargetName));
    SID_IDropHandler := Reg.ReadString('');
    if SID_IDropHandler = '' then exit;
    Reg.CloseKey;
    Reg.OpenKeyReadOnly(SID_IDropHandler + '\ShellEx\DropHandler');
    SID_IDropHandler := Reg.ReadString('');
    if SID_IDropHandler = '' then exit;
  finally
    Reg.Free;
    end;

// Intialize IDs
  if CLSIDFromString(StringToOLEStr(PChar(SID_IDropHandler)),GUID_DropHandler) <> S_OK then exit;
  if CLSIDFromString(StringToOLEStr(PChar(SID_IDropTarget )),GUID_DropTarget ) <> S_OK then exit;

// Create the Drag&Drop recipient handle
  if CoCreateInstance(GUID_DropHandler,nil,CLSCTX_INPROC_SERVER,GUID_DropTarget,DropTarget) <> S_OK then exit;

// Get the file IDataObject interface
  DataObject := GetFileDataObject(FileName);
  if DataObject = nil then exit;

// Simulate the Drag & Drop operation
  if DropTarget.DragEnter(DataObject,MK_LBUTTON,Point(0,0),DropEffect) <> S_OK then exit;
  if DropTarget.Drop     (DataObject,MK_LBUTTON,Point(0,0),DropEffect) <> S_OK then exit;
  Result := true;
  end;  { DragDropFileToTarget }



initialization
OleInitialize(nil);

finalization
OleUninitialize;
end.