Having a (send-to) Menu In Your Programs (Views: 27)
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 !! |