Пример добавления пункта в контекстное меню 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

.

Другое по теме:

• Очистка кэша в IE
• WEB страничка внутри Delphi приложения
• Автоматическое заполнение HTML-форм в браузере