Техническая поддержка :

Современные решения

для защиты Windows программ

и восстановления исходного кода
Автор: C Pringle. Дата публикации: 22.08.2004

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



CODE NOW!

// Откройте 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.






Комментарии

отсутствуют

Добавление комментария


Ваше имя (на форуме):

Ваш пароль (на форуме):

Комментарии могут добавлять только пользователи,
зарегистрированные на форуме данного сайта. Если Вы не
зарегистрированы, то сначала зарегистрируйтесь тут

Комментарий:





Главная     Программы     Статьи     Разное     Форум     Контакты