Author: Abu Zant Ruslan
If you are interested in getting the windows send-to menu in your programs, try the
following code !!
Answer:
Here Is The Whole Unit
1 unit uSendTo;
2
3 interface
4
5 uses
6 SysUtils, Windows, Messages, Classes, Controls, Forms,
7 Dialogs, StdCtrls, ExtCtrls, Menus, ComCtrls, FileCtrl,
8 ShellAPI, ShlObj, ActiveX, ComObj;
9
10 // Very basic example - a Form with a FileListBox and a PopupMenu...
11 type
12 TForm1 = class(TForm)
13 PopupMenu1: TPopupMenu;
14 FileListBox1: TFileListBox;
15 procedure FormCreate(Sender: TObject);
16 private
17 procedure SendToItemClick(Sender: TObject); // MenuItem event-handler
18 public
19 { Public declarations }
20 end;
21
22 // declare a special type of TMenuItem to store the EXE name...
23 type
24 TMyMenuItem = class(TMenuItem)
25 public Verb: string;
26 end;
27
28 var
29 Form1: TForm1;
30 implementation
31
32 {$R *.DFM}
33
34 // a pipe-delimited list of file extensions that are normally hidden...
35 const
36 HiddenExtensions = '.LNK|.DESKLINK|.MYDOCS|.MAPIMAIL';
37
38 // Get path to the SendTo folder (Like Madshi says) ...
39
40 function GetSendToFolder: string;
41 var
42 pIDL: pItemIDList;
43 Buffer: array[0..MAX_PATH] of char;
44 Malloc: IMalloc;
45 begin
46 SHGetSpecialFolderLocation(0, CSIDL_SENDTO, pIDL);
47 ShGetPathFromIdList(pIDL, PChar(@Buffer));
48 Result := Buffer;
49 OLECheck(SHGetMalloc(Malloc));
50 if pIDL <> nil then
51 Malloc.Free(pIDL);
52 end;
53
54 // Recursive function to find all items in SendTo folder
55 // Creates sub-menu items if the folder has sub-directories...
56
57 procedure CreateMenuItems(Path: string; aMenuItem: TMenuItem);
58 var
59 SR: TSearchRec;
60 MI: TMyMenuItem;
61 procedure AddIf;
62 begin
63 if SR.Attr and faDirectory <= 0 then
64 begin // if it's a file
65 MI := TMyMenuItem.Create(Form1);
66 if pos(UpperCase(ExtractFileExt(SR.Name)), HiddenExtensions) > 0 then
67 MI.Caption := ChangeFileExt(SR.Name, '')
68 else
69 MI.Caption := SR.Name;
70 MI.Verb := Path + SR.Name;
71 MI.OnClick := Form1.SendToItemClick; //Assign event handler
72 aMenuItem.Add(MI)
73 end
74 else if SR.Name[1] <> '.' then
75 begin // if it's a folder
76 MI := TMyMenuItem.Create(Form1);
77 MI.Caption := SR.Name;
78 aMenuItem.Add(MI);
79 CreateMenuItems(Path + SR.Name, MI); // Recursive call
80 end;
81 end;
82 begin
83 if Path[Length(Path)] <> '\' then
84 Path := Path + '\';
85 if FindFirst(Path + '*', faAnyFile, SR) = 0 then
86 begin
87 AddIf;
88 while FindNext(SR) = 0 do
89 AddIf;
90 end;
91 end;
92
93 // Find the EXE that the shortcut points to -
94 // Adapted from Elliott Shevin's TShortcutLink component
95 // (this could be modified to get the icon, ShowState, etc... )
96
97 function GetShortcutTarget(ShortcutFilename: string): string;
98 var
99 Psl: IShellLink;
100 Ppf: IPersistFile;
101 WideName: array[0..MAX_PATH] of WideChar;
102 pResult: array[0..MAX_PATH - 1] of Char;
103 Data: TWin32FindData;
104 const
105 IID_IPersistFile: TGUID = (D1: $0000010B; D2: $0000; D3: $0000; D4:
106 ($C0, $00, $00, $00, $00, $00, $00, $46));
107 begin
108 CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IID_IShellLinkA,
109 psl);
110 psl.QueryInterface(IID_IPersistFile, ppf);
111 MultiByteToWideChar(CP_ACP, 0, pChar(ShortcutFilename), -1, WideName, Max_Path);
112 ppf.Load(WideName, STGM_READ);
113 psl.Resolve(0, SLR_ANY_MATCH);
114 psl.GetPath(@pResult, MAX_PATH, Data, SLGP_UNCPRIORITY);
115 Result := StrPas(@pResult);
116 end;
117
118 procedure TForm1.SendToItemClick(Sender: TObject);
119 begin
120 // Just shows the filename - you could use ShellExecute or CreateProcess instead
121 // But need some special handling for MyDocuments, Desktop and MailRecipient
122 ShowMessage(GetShortcutTarget(TMyMenuItem(Sender).Verb));
123 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...
124
125 // Recursive function to find all items in SendTo folder
126 // Creates sub-menu items if the folder has sub-directories...
127
128 procedure CreateMenuItems(Path: string; aMenuItem: TMenuItem);
129 var
130 SR: TSearchRec;
131 MI: TMyMenuItem;
132 oSHFileInfo: SHFileInfo;
133
134 procedure AddItemToMenu;
135 begin
136 MI := TMyMenuItem.Create(Form1);
137
138 if SR.Attr and faDirectory <= 0 then
139 begin // if it's a file
140 // get system file information for item
141 FillChar(oSHFileInfo, Sizeof(SHFileInfo), 0);
142
143 // get systems' "proper" name for item
144 SHGetFileInfo(PChar(Path + SR.Name), 0, oSHFileInfo, Sizeof(SHFileInfo),
145 SHGFI_DISPLAYNAME);
146 MI.Caption := oSHFileInfo.szDisplayName;
147
148 MI.Verb := Path + SR.Name;
149 MI.OnClick := Form1.SendToItemClick; //Assign event handler
150 aMenuItem.Add(MI);
151
152 end
153 else if SR.Name[1] <> '.' then
154 begin // if it's a folder
155 MI.Caption := SR.Name;
156 aMenuItem.Add(MI);
157 CreateMenuItems(Path + SR.Name, MI); // Recursive call
158 end;
159 end;
160 begin
161 Path := IncludeTrailingBackSlash(Path);
162 if FindFirst(Path + '*', faAnyFile, SR) = 0 then
163 begin
164 try
165 repeat
166 AddItemToMenu;
167 until (FindNext(SR) <> 0);
168 finally
169 FindClose(SR);
170 end;
171 end;
172 end;
173
174 procedure TForm1.FormCreate(Sender: TObject);
175 begin
176 CreateMenuItems(GetSendToFolder(), popupmenu1.Items);
177 // to mimic the windows Send to menu you will:
178 // 1. need to sort popupmenu1.Items alphabetically
179 // 2. retrieve the icons
180 // 3. find out how to execute them!
181 end;
Have Fun !!
|
