Как добавить свое меню в проводник

← →
OlegM (2006-08-24 06:32) [0]

Например как делает это WinRAR

← →
PSPF2003 © (2006-08-24 09:12) [1]

Sendtoweb.dpr
========================
// This COM server defines a Context Menu shell extension. This allows the user
// to right click on Delphi Project files (.DPR) from the Explorer and compile
// them using the DCC32.exe command line compiler.
library ContMenu;
uses
ComServ,
Sendtoweb in "Sendtoweb.pas";
exports
DllGetClassObject,
DllCanUnloadNow,
DllRegisterServer,
DllUnregisterServer;
begin
end.

Sendtoweb.pas
====================
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, 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 = (
"-","D:\","Borland","Program Files"
);

const
Class_ContextMenu: TGUID = "{2D782E1B-A136-4D89-8B4A-1571E5386078}";
implementation

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.dll",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;

{ Построение контекстного меню с использованием хэндла существующего меню. Если 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;

function TContextMenu.IShellExtInit_Initialize( pidlFolder: PItemIDList;
lpdobj: IDataObject; hKeyProgID: HKEY ): HResult;
var
medium: TStgMedium;
fe: TFormatEtc;

← →
PSPF2003 © (2006-08-24 09:12) [2]

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;

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("d:"), nil, nil, SW_SHOW );
End;
3 : Begin
ShellExecute( GetDesktopWindow, nil,Pchar("D:\Program Files"),
nil, nil, SW_SHOW );
End;
2 : ShellExecute( GetDesktopWindow, nil,Pchar("D:\Program Files\Borland\Delphi7"),
nil, 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.

← →
Ketmar © (2006-08-24 09:58) [3]

слушай, а зачем такие цитаты? может, просто в каталог с демками посылать? %-)

← →
tButton © (2006-08-24 10:01) [4]

// предвкушаю вопрос "а как его теперь оттуда убрать?"

> Ketmar

Я не помню в каком каталоге она находится :

Как добавить свое меню в проводник Найти похожие ветки