Извиняюсь я опять со своими хотелками но насчет меню вот еще Да простит мне администрация Вот код добавления пункта контекстного меню как делает это WinRar
Добавление пункта в контекстное меню 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*ShellExContextMenuHandlers.
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 := 'SOFTWAREMicrosoftWindowsCurrentVersionApp 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( '*ShellExContextMenuHandlersSendToWeb', '',
GUIDToString( Class_ContextMenu ) );
CreateRegKey( 'CLSID' + GUIDToString( ClassID ) + '' +
ComServer.ServerKey, 'ThreadingModel', 'Apartment' );
end else
begin
DeleteRegKey( '*ShellExContextMenuHandlersSendToWeb' );
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.
или можешь почитать http://ddsoft.hoha.ru/docs/shell1/ прошу не банить за ссылку на другой ресурс.... или ниже прикрепляю исходник shellasrc.rar
