Author: Jonas Bilinkevicius
How to add menu items to windows explorer / desktop context menu
Answer:
1 // Open Delphi select dynamic link library
2 // Copy / paste this into the DLL
3 // Then compile
4 // You will have to customize this code. To suite your needs.
5 // once the dll has been compiled you will now have to register this
6 // com server.
7 // Use regsvr32.exe sendtoweb.dll
8 // now open windows explorer and you will see a new menu item
9 // which can be accessed by the desktop also..
10
11 unit Sendtoweb;
12
13 // Author C Pringle Cjpsoftware.com
14
15 { Implementation of the context menu shell extension COM object. This
16 COM object is responsible for forwarding requests to its partner
17 TPopupMenu component. The TPopupMenu component must reside on the
18 MenuComponentForm, and is referred to explicitly in this example.
19 You can modify this code to make it more flexible and generic in
20 the future.
21
22 The TContextMenu component registers itself as a global context menu
23 handler. This is accomplished by adding a key to the
24 HKEY_CLASSES_ROOT\*\ShellEx\ContextMenuHandlers key in the registry.
25
26 jfl
27 }
28
29 interface
30
31 uses
32
33 Classes, ComServ, ComObj, ActiveX, Windows, ShlObj, Interfaces, Menus,
34 ShellAPI, SysUtils, registry;
35
36 type
37 TContextMenuFactory = class(TComObjectFactory)
38 public
39 procedure UpdateRegistry(register: Boolean); override;
40 end;
41
42 TContextMenu = class(TComObject, IShellExtInit, IContextMenu)
43 private
44 FFileName: string;
45 function BuildSubMenu(Menu: HMENU; IndexMenu: Integer;
46 var IDCmdFirst: Integer): HMENU;
47 protected
48 szFile: array[0..MAX_PATH] of Char;
49 // Required to disambiguate TComObject.Initialize otherwise a compiler
50 // warning will result.
51 function IShellExtInit.Initialize = IShellExtInit_Initialize;
52 public
53 { IShellExtInit members }
54 function IShellExtInit_Initialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
55 hKeyProgID: HKEY): HResult; stdcall;
56 { IContextMenu }
57 function QueryContextMenu(Menu: HMENU;
58 indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HResult; stdcall;
59 function InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; stdcall;
60 function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
61 pszName: LPSTR; cchMax: UINT): HResult; stdcall;
62 end;
63
64 var
65 // Must be set prior to instantiation of TContextMenu!
66 GFileExtensions: TStringList;
67
68 const
69 MenuCommandStrings: array[0..3] of string = (
70 '', '&STW Web Upload', '&STW FTPClient', '&STW Setup'
71 );
72
73 implementation
74
75 { TContextMenuFactory }
76 { Public }
77
78 function ReadDefaultPAth: string;
79 var
80 path: string;
81 Reg: TRegistry;
82 begin
83
84 Reg := TRegistry.CReate;
85 try
86 with Reg do
87 begin
88 RootKey := HKEY_LOCAL_MACHINE;
89 Path := 'SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths';
90
91 if KeyExists(Path) then
92 begin
93 OpenKey(Path + '\sendtoweb.exe', false);
94 Result := ReadString(#0);
95 closekey;
96 end;
97
98 // Key Added to shell ext.
99
100 end;
101 finally
102 Reg.CloseKey;
103 Reg.Free;
104 end;
105
106 end; // Custom registration code
107
108 procedure TContextMenuFactory.UpdateRegistry(register: Boolean);
109 begin
110 inherited UpdateRegistry(register);
111
112 // Register our global context menu handler
113 if register then
114 begin
115 CreateRegKey('*\ShellEx\ContextMenuHandlers\SendToWeb', '',
116 GUIDToString(Class_ContextMenu));
117 CreateRegKey('CLSID\' + GUIDToString(ClassID) + '\' +
118 ComServer.ServerKey, 'ThreadingModel', 'Apartment');
119 end
120 else
121 begin
122 DeleteRegKey('*\ShellEx\ContextMenuHandlers\SendToWeb');
123 end;
124 end;
125
126 { TContextMenu }
127 { Private }
128
129 { Build a context menu using the existing Menu handle. If Menu is nil,
130 we create a new menu handle and return it in the function's return
131 value. Note that this function does not handle nested (recursive)
132 menus. This exercise is left to the reader. }
133
134 function TContextMenu.BuildSubMenu(Menu: HMENU; IndexMenu: Integer;
135 var IDCmdFirst: Integer): HMENU;
136 var
137 i: Integer;
138 menuItemInfo: TMenuItemInfo;
139 begin
140 if Menu = 0 then
141 Result := CreateMenu
142 else
143 Result := Menu;
144
145 // Build the menu items here
146 with menuitemInfo do
147 begin
148 cbSize := SizeOf(TMenuItemInfo);
149 fMask := MIIM_CHECKMARKS or MIIM_DATA or MIIM_ID or
150 MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE or MIIM_CHECKMARKS;
151 fType := MFT_STRING;
152 fState := MFS_ENABLED;
153 hSubMenu := 0;
154 hbmpChecked := 0;
155 hbmpUnchecked := 0;
156 end;
157
158 for i := 0 to High(MenuCommandStrings) do
159 begin
160 if i = 0 then
161 menuitemInfo.fType := MFT_SEPARATOR
162 else
163 menuiteminfo.ftype := MFT_String;
164 if i = 1 then
165 menuitemInfo.fstate := MFS_ENABLED or MFS_DEFAULT
166 else
167 menuitemInfo.fstate := MFS_ENABLED;
168
169 menuitemInfo.dwTypeData := PChar(MenuCommandStrings[i]);
170 menuitemInfo.wID := IDCmdFirst;
171 InsertMenuItem(Result, IndexMenu + i, True, menuItemInfo);
172 Inc(IDCmdFirst);
173 end;
174 end;
175
176 { IShellExtInit }
177
178 function TContextMenu.IShellExtInit_Initialize(pidlFolder: PItemIDList;
179 lpdobj: IDataObject; hKeyProgID: HKEY): HResult;
180 var
181 medium: TStgMedium;
182 fe: TFormatEtc;
183
184 begin
185 with fe do
186 begin
187 cfFormat := CF_HDROP;
188 ptd := nil;
189 dwAspect := DVASPECT_CONTENT;
190 lindex := -1;
191 tymed := TYMED_HGLOBAL;
192 end;
193 // Fail the call if lpdobj is Nil.
194 if lpdobj = nil then
195 begin
196 Result := E_FAIL;
197 Exit;
198 end;
199 // Render the data referenced by the IDataObject pointer to an HGLOBAL
200 // storage medium in CF_HDROP format.
201 Result := lpdobj.GetData(fe, medium);
202 if Failed(Result) then
203 Exit;
204 // If only one file is selected, retrieve the file name and store it in
205 // szFile. Otherwise fail the call.
206 if DragQueryFile(medium.hGlobal, $FFFFFFFF, nil, 0) = 1 then
207 begin
208 DragQueryFile(medium.hGlobal, 0, szFile, SizeOf(szFile));
209 Result := NOERROR;
210 end
211 else
212 Result := E_FAIL;
213 ReleaseStgMedium(medium);
214 end;
215
216 { IContextMenu }
217
218 function TContextMenu.QueryContextMenu(Menu: HMENU;
219 indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HResult;
220 var
221 extension: string;
222 I: Integer;
223 idLastCommand: Integer;
224 begin
225 Result := E_FAIL;
226 idLastCommand := idCmdFirst;
227
228 // Extract the filename extension from the file dropped, and see if we
229 // have a handler registered for it
230 // extension := UpperCase( ( FFileName ) );
231
232 //for i := 0 to GFileExtensions.Count - 1 do
233 // if Pos(Lowercase(GFileExtensions[ i ]),lowercase(extension))=0 then
234 // begin
235 BuildSubMenu(Menu, indexMenu, idLastCommand);
236 // Return value is number of items added to context menu
237 Result := idLastCommand - idCmdFirst;
238 // Exit;
239 // end;
240 end;
241
242 function TContextMenu.InvokeCommand(var lpici:
243 TCMInvokeCommandInfo): HResult;
244 var
245 idCmd: UINT;
246 begin
247 if HIWORD(Integer(lpici.lpVerb)) <> 0 then
248 Result := E_FAIL
249 else
250 begin
251 idCmd := LOWORD(lpici.lpVerb);
252 Result := S_OK;
253
254 // Activate the Dialog And prepare to send data to the
255 // web
256
257 case idCmd of
258 1:
259 begin
260
261 ShellExecute(GetDesktopWindow, nil,
262 Pchar(ExtractFileName(ReadDefaultPath)),
263 Pchar('Direct' + '"' + szfile + '"'), nil, SW_SHOW);
264
265 end;
266 3:
267 begin
268 ShellExecute(GetDesktopWindow, nil,
269 Pchar(ExtractFileName(ReadDefaultPath)),
270 Pchar('Path'), nil, SW_SHOW);
271
272 end;
273 2:
274 ShellExecute(GetDesktopWindow, nil, Pchar(ExtractFileName(ReadDefaultPath)),
275 PChar(''), nil, SW_SHOW);
276 else
277 Result := E_FAIL;
278 end;
279 end;
280 end;
281
282 function TContextMenu.GetCommandString(idCmd, uType: UINT;
283 pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult;
284
285 begin
286 // StrCopy( pszName, 'Send To The Web') ;
287
288 Result := S_OK;
289 end;
290
291 initialization
292 { Note that we create an instance of TContextMenuFactory here rather
293 than TComObjectFactory. This is necessary so that we can add some
294 custom registry entries by overriding the UpdateRegistry virtual
295 function. }
296 TContextMenuFactory.Create(ComServer, TContextMenu, Class_ContextMenu,
297 'ContextMenu', 'Send To The Web', ciMultiInstance);
298
299 // Initialize the file extension list
300 GFileExtensions := TStringList.Create;
301 // GFileExtensions.Add( 'setup msn' );
302
303 finalization
304 GFileExtensions.Free;
305
306 end.
|
