Пример добавления пункта в контекстное меню Windows Explorer

// Откройте Delphi, выберите в меню New... Dynamic link library // Скопируйте нижеприведенный текст DLL // Скомпилируйте проект. // Теперь нужно зарегистрировать полученную библиотеку. // Наберите в командной строке regsvr32.exe sendtoweb.dll // После этого откройте Windows Explorer и вы увидите новый // пункт меню... unit Sendtoweb; // Author C Pringle Cjpsoftware.com { Реализация COM объекта расширения оболочки Windows Explorer. Этот COM объект способен перенаправлять запросы компоненту TPopupMenu. Компонент TPopupMenu должен находиться на форме MenuComponentForm. Вы можете модернизировать код для большей гибкости. Компонент TContextMenu регистрируется как глобальным обработчик контекстного меню. Это достигается модификацией ключа реестра HKEY_CLASSES_ROOT\*\ShellEx\ContextMenuHandlers. jfl } interface uses Classes, ComServ, ComObj, ActiveX, Windows, ShlObj, Interfaces, Menus, ShellAPI, SysUtils, registry; type TContextMenuFactory = class(TComObjectFactory) public procedure UpdateRegistry(Register: Boolean); override; end; TContextMenu = class(TComObject, IShellExtInit, IContextMenu) private FFileName: string; function BuildSubMenu(Menu: HMENU; IndexMenu: Integer; var IDCmdFirst: Integer): HMENU; protected szFile: array[0..MAX_PATH] of Char; // Необходимо для исключения предупреждения компилятора о неоднозначности function IShellExtInit.Initialize = IShellExtInit_Initialize; public { IShellExtInit } function IShellExtInit_Initialize(pidlFolder: PItemIDList; lpdobj: IDataObject; hKeyProgID: HKEY): HResult; stdcall; { IContextMenu } function QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HResult; stdcall; function InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; stdcall; function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult; stdcall; end; var // Должен быть инициализирован перед регистрацией TContextMenu! GFileExtensions: TStringList; const MenuCommandStrings: array[0..3] of string = ( '', '&STW; Web Upload', '&STW; FTPClient', '&STW; Setup' ); implementation { TContextMenuFactory } { Public } function ReadDefaultPAth: string; var path: string; Reg: TRegistry; begin Reg := TRegistry.CReate; try with Reg do begin RootKey := HKEY_LOCAL_MACHINE; Path := 'SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths'; if KeyExists(Path) then begin OpenKey(Path + '\sendtoweb.exe', false); Result := ReadString(#0); closekey; end; // Ключ добавлен в реестр. end; finally Reg.CloseKey; Reg.Free; end; end; // Код регистрации procedure TContextMenuFactory.UpdateRegistry(Register: Boolean); begin inherited UpdateRegistry(Register); // Регистрация нашего обработчика if Register then begin CreateRegKey('*\ShellEx\ContextMenuHandlers\SendToWeb', '', GUIDToString(Class_ContextMenu)); CreateRegKey('CLSID\' + GUIDToString(ClassID) + '\' + ComServer.ServerKey, 'ThreadingModel', 'Apartment'); end else begin DeleteRegKey('*\ShellEx\ContextMenuHandlers\SendToWeb'); end; end; { TContextMenu } { Private } { Построение контекстного меню с использованием хэндла существующего меню. Если Menu = nil, мы создаем новый хэндл меню и возвращаем его как результат функции. Заметьте, что обработчик не поддерживаетвложенные (рекурсивные) меню. } function TContextMenu.BuildSubMenu(Menu: HMENU; IndexMenu: Integer; var IDCmdFirst: Integer): HMENU; var i: Integer; menuItemInfo: TMenuItemInfo; begin if Menu = 0 then Result := CreateMenu else Result := Menu; // Подготавливаем меню with menuitemInfo do begin cbSize := SizeOf(TMenuItemInfo); fMask := MIIM_CHECKMARKS or MIIM_DATA or MIIM_ID or MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE or MIIM_CHECKMARKS; fType := MFT_STRING; fState := MFS_ENABLED; hSubMenu := 0; hbmpChecked := 0; hbmpUnchecked := 0; end; for i := 0 to High(MenuCommandStrings) do begin if i = 0 then menuitemInfo.fType := MFT_SEPARATOR else menuiteminfo.ftype := MFT_String; if i = 1 then menuitemInfo.fstate := MFS_ENABLED or MFS_DEFAULT else menuitemInfo.fstate := MFS_ENABLED; menuitemInfo.dwTypeData := PChar(MenuCommandStrings[i]); menuitemInfo.wID := IDCmdFirst; InsertMenuItem(Result, IndexMenu + i, True, menuItemInfo); Inc(IDCmdFirst); end; end; { IShellExtInit } function TContextMenu.IShellExtInit_Initialize(pidlFolder: PItemIDList; lpdobj: IDataObject; hKeyProgID: HKEY): HResult; var medium: TStgMedium; fe: TFormatEtc; begin with fe do begin cfFormat := CF_HDROP; ptd := nil; dwAspect := DVASPECT_CONTENT; lindex := -1; tymed := TYMED_HGLOBAL; end; // Ошибка, если lpdobj = Nil. if lpdobj = nil then begin Result := E_FAIL; Exit; end; Result := lpdobj.GetData(fe, medium); if Failed(Result) then Exit; // Если выбран только один файл, получаем его имя и сохраняем в // szFile. иначе - ошибка. if DragQueryFile(medium.hGlobal, $FFFFFFFF, nil, 0) = 1 then begin DragQueryFile(medium.hGlobal, 0, szFile, SizeOf(szFile)); Result := NOERROR; end else Result := E_FAIL; ReleaseStgMedium(medium); end; { IContextMenu } function TContextMenu.QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HResult; var extension: string; I: Integer; idLastCommand: Integer; begin Result := E_FAIL; idLastCommand := idCmdFirst; // Получаем расширение файла и определяем, есть ли для него // зарегистрированный обработчик // extension := UpperCase( ( FFileName ) ); //for i := 0 to GFileExtensions.Count - 1 do // if Pos(Lowercase(GFileExtensions[ i ]),lowercase(extension))=0 then // begin BuildSubMenu(Menu, indexMenu, idLastCommand); // Return value is number of items added to context menu Result := idLastCommand - idCmdFirst; // Exit; // end; end; function TContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; var idCmd: UINT; begin if HIWORD(Integer(lpici.lpVerb)) <> 0 then Result := E_FAIL else begin idCmd := LOWORD(lpici.lpVerb); Result := S_OK; // Активизация диалога и подготовка к послке данных в Web case idCmd of 1: begin ShellExecute(GetDesktopWindow, nil, Pchar(ExtractFileName(ReadDefaultPath)), Pchar('Direct' + '"' + szfile + '"'), nil, SW_SHOW); end; 3: begin ShellExecute(GetDesktopWindow, nil, Pchar(ExtractFileName(ReadDefaultPath)), Pchar('Path'), nil, SW_SHOW); end; 2: ShellExecute(GetDesktopWindow, nil, Pchar(ExtractFileName(ReadDefaultPath)), PChar(''), nil, SW_SHOW); else Result := E_FAIL; end; end; end; function TContextMenu.GetCommandString(idCmd, uType: UINT; pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult; begin // StrCopy( pszName, 'Send To The Web') ; Result := S_OK; end; initialization { Заметьте, что в данном фрагменте мы создаем экземпляр TContextMenuFactory, а не TComObjectFactory. } TContextMenuFactory.Create(ComServer, TContextMenu, Class_ContextMenu, 'ContextMenu', 'Send To The Web', ciMultiInstance); // Инициализируем список расширений GFileExtensions := TStringList.Create; // GFileExtensions.Add( 'setup msn' ); finalization GFileExtensions.Free; end.