Having a (send-to) Menu In Your Programs

Problem/Question/Abstract:

If you are interested in getting the windows send-to menu in your programs, try the following code !!

Answer:

Here Is The Whole Unit

unit uSendTo;

interface

uses
  SysUtils, Windows, Messages, Classes, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, Menus, ComCtrls, FileCtrl,
  ShellAPI, ShlObj, ActiveX, ComObj;

// Very basic example - a Form with a FileListBox and a PopupMenu...
type
  TForm1 = class(TForm)
    PopupMenu1: TPopupMenu;
    FileListBox1: TFileListBox;
    procedure FormCreate(Sender: TObject);
  private
    procedure SendToItemClick(Sender: TObject); // MenuItem event-handler
  public
    { Public declarations }
  end;

  // declare a special type of TMenuItem to store the EXE name...
type
  TMyMenuItem = class(TMenuItem)
  public Verb: string;
  end;

var
  Form1: TForm1;
implementation

{$R *.DFM}

// a pipe-delimited list of file extensions that are normally hidden...
const
  HiddenExtensions = '.LNK|.DESKLINK|.MYDOCS|.MAPIMAIL';

  // Get path to the SendTo folder (Like Madshi says) ...

function GetSendToFolder: string;
var
  pIDL: pItemIDList;
  Buffer: array[0..MAX_PATH] of char;
  Malloc: IMalloc;
begin
  SHGetSpecialFolderLocation(0, CSIDL_SENDTO, pIDL);
  ShGetPathFromIdList(pIDL, PChar(@Buffer));
  Result := Buffer;
  OLECheck(SHGetMalloc(Malloc));
  if pIDL <> nil then
    Malloc.Free(pIDL);
end;

// Recursive function to find all items in SendTo folder
// Creates sub-menu items if the folder has sub-directories...

procedure CreateMenuItems(Path: string; aMenuItem: TMenuItem);
var
  SR: TSearchRec;
  MI: TMyMenuItem;
  procedure AddIf;
  begin
    if SR.Attr and faDirectory <= 0 then
    begin // if it's a file
      MI := TMyMenuItem.Create(Form1);
      if pos(UpperCase(ExtractFileExt(SR.Name)), HiddenExtensions) > 0 then
        MI.Caption := ChangeFileExt(SR.Name, '')
      else
        MI.Caption := SR.Name;
      MI.Verb := Path + SR.Name;
      MI.OnClick := Form1.SendToItemClick; //Assign event handler
      aMenuItem.Add(MI)
    end
    else if SR.Name[1] <> '.' then
    begin // if it's a folder
      MI := TMyMenuItem.Create(Form1);
      MI.Caption := SR.Name;
      aMenuItem.Add(MI);
      CreateMenuItems(Path + SR.Name, MI); // Recursive call
    end;
  end;
begin
  if Path[Length(Path)] <> '\' then
    Path := Path + '\';
  if FindFirst(Path + '*', faAnyFile, SR) = 0 then
  begin
    AddIf;
    while FindNext(SR) = 0 do
      AddIf;
  end;
end;

// Find the EXE that the shortcut points to -
// Adapted from Elliott Shevin's TShortcutLink component
// (this could be modified to get the icon, ShowState, etc... )

function GetShortcutTarget(ShortcutFilename: string): string;
var
  Psl: IShellLink;
  Ppf: IPersistFile;
  WideName: array[0..MAX_PATH] of WideChar;
  pResult: array[0..MAX_PATH - 1] of Char;
  Data: TWin32FindData;
const
  IID_IPersistFile: TGUID = (D1: $0000010B; D2: $0000; D3: $0000; D4:
    ($C0, $00, $00, $00, $00, $00, $00, $46));
begin
  CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IID_IShellLinkA, psl);
  psl.QueryInterface(IID_IPersistFile, ppf);
  MultiByteToWideChar(CP_ACP, 0, pChar(ShortcutFilename), -1, WideName, Max_Path);
  ppf.Load(WideName, STGM_READ);
  psl.Resolve(0, SLR_ANY_MATCH);
  psl.GetPath(@pResult, MAX_PATH, Data, SLGP_UNCPRIORITY);
  Result := StrPas(@pResult);
end;

procedure TForm1.SendToItemClick(Sender: TObject);
begin
  // Just shows the filename - you could use ShellExecute or CreateProcess instead
  // But need some special handling for MyDocuments, Desktop and MailRecipient
  ShowMessage(GetShortcutTarget(TMyMenuItem(Sender).Verb));
end;

after compiling, it will be very easy to U to ge the needed functions and add them tto your own applications !!


!! OR TRY THIS MORE DEBUGGED VERSION !!!

Fixed:

1. Memory leak (no FindClose)
2. Kludge for removing file extensions that are normally hidden (now uses WinAPI to get the descriptive name)
3. Removed unessary duplication (Addif; while, etc - changed to repeat)
4. Added the all important but missing FormCreate event to show how this works...


// Recursive function to find all items in SendTo folder
// Creates sub-menu items if the folder has sub-directories...

procedure CreateMenuItems(Path: string; aMenuItem: TMenuItem);
var
  SR: TSearchRec;
  MI: TMyMenuItem;
  oSHFileInfo: SHFileInfo;

  procedure AddItemToMenu;
  begin
    MI := TMyMenuItem.Create(Form1);

    if SR.Attr and faDirectory <= 0 then
    begin // if it's a file
      // get system file information for item
      FillChar(oSHFileInfo, Sizeof(SHFileInfo), 0);

      // get systems' "proper" name for item
      SHGetFileInfo(PChar(Path + SR.Name), 0, oSHFileInfo, Sizeof(SHFileInfo),
        SHGFI_DISPLAYNAME);
      MI.Caption := oSHFileInfo.szDisplayName;

      MI.Verb := Path + SR.Name;
      MI.OnClick := Form1.SendToItemClick; //Assign event handler
      aMenuItem.Add(MI);

    end
    else if SR.Name[1] <> '.' then
    begin // if it's a folder
      MI.Caption := SR.Name;
      aMenuItem.Add(MI);
      CreateMenuItems(Path + SR.Name, MI); // Recursive call
    end;
  end;
begin
  Path := IncludeTrailingBackSlash(Path);
  if FindFirst(Path + '*', faAnyFile, SR) = 0 then
  begin
    try
      repeat
        AddItemToMenu;
      until (FindNext(SR) <> 0);
    finally
      FindClose(SR);
    end;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  CreateMenuItems(GetSendToFolder(), popupmenu1.Items);
  // to mimic the windows Send to menu you will:
  // 1. need to sort popupmenu1.Items alphabetically
  // 2. retrieve the icons
  // 3. find out how to execute them!
end;

Have Fun !!