На главную Наши проекты:
Журнал   ·   Discuz!ML   ·   Wiki   ·   DRKB   ·   Помощь проекту
ПРАВИЛА FAQ Помощь Участники Календарь Избранное RSS
msm.ru
Модераторы: Rouse_, jack128, Krid
  
    > Как зарегистрировать свою команду в контекстном меню проводника
      Для подобных действий пишется маленький комсервер задача которого лишь реализовать 2 интерфейса IShellExtInit и IContextMenu.
      Для чего это делается - операционная система при инициализации меню проверит твою библиотеку на предмет: поддерживает ли она эти интерфейсы и если да - то вызовет нужные их методы. Ну а уж при срабатывании данных методов ты и добавляешь свои пункты меню.

      Для облегчения отладки, чтобы библиотека выгружалась сразу же как только не используется производим следующие действия:

      В реестре вот по этому пути HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer устанавливаем строковое значение AlwaysUnloadDLL равным "1" (если такого значения нет, тогда нужно его создать).

      Далее пишем код:

      вот реализация сервера:

      ExpandedWrap disabled
        // Test COM Server Shell Context menu extention
         
        library CONTMENU;
         
        uses
          ComServ,
          ContextM in 'ContextM.pas';
         
        exports
          DllGetClassObject,
          DllCanUnloadNow,
          DllRegisterServer,
          DllUnregisterServer;
         
        begin
        end.


      ExpandedWrap disabled
        unit ContextM;
         
        interface
         
        uses
          Windows, ActiveX, ComObj, ShlObj;
         
        type
          TContextMenu = class(TComObject, IShellExtInit, IContextMenu)
          private
            FFileName: array[0..MAX_PATH] of Char;
            TmpFileNames:String;
          protected
            { IShellExtInit }
            function IShellExtInit.Initialize = SEIInitialize;
            function SEIInitialize(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;
         
        resourcestring
          IDC_TEST1 = 'Тестовая строка номер 1';
          IDC_TEST2 = 'Тестовая строка номер 2';
         
        const
          Class_ContextMenu: TGUID = '{45C15F61-ACAD-48C6-8D86-321ED8A6CFC6}';
         
        implementation
         
        uses ComServ, SysUtils, ShellApi, Registry, Graphics;
         
        // Тут наше меню инициализируется
        // на вход приходит интерфейс IDataObject из которого мы можем получить
        // список файлов и папок над которыми будут происходить действия
        function TContextMenu.SEIInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
          hKeyProgID: HKEY): HResult;
        var
          StgMedium: TStgMedium;
          FormatEtc: TFormatEtc;
          FilesCount,I:Integer;
        begin
         
          if (lpdobj = nil) then
          begin
            Result := E_INVALIDARG;
            Exit;
          end;
         
          with FormatEtc do begin
            cfFormat := CF_HDROP;
            ptd      := nil;
            dwAspect := DVASPECT_CONTENT;
            lindex   := -1;
            tymed    := TYMED_HGLOBAL;
          end;
         
          Result := lpdobj.GetData(FormatEtc, StgMedium);
          if Failed(Result) then Exit;
         
          TmpFileNames := '';
          FilesCount := DragQueryFile(StgMedium.hGlobal, $FFFFFFFF, nil, 0);
          for I:= 0 to FilesCount - 1 do
          begin
            DragQueryFile(StgMedium.hGlobal, I, FFileName, SizeOf(FFileName));
            TmpFileNames := TmpFileNames + '"'+FFileName+'" ';
          end;
          Result := NOERROR;
          ReleaseStgMedium(StgMedium);
        end;
         
        // Создание меню
        // по этому событию мы добавляем новые элементы меню...
        function TContextMenu.QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst,
                  idCmdLast, uFlags: UINT): HResult;
        begin
          Result := MakeResult(SEVERITY_SUCCESS, FACILITY_NULL, 0);
         
          if ((uFlags and $0000000F) = CMF_NORMAL) or
             ((uFlags and CMF_EXPLORE) <> 0) then
          begin
            // Разделитель
            InsertMenu(Menu, indexMenu, MF_SEPARATOR or MF_BYPOSITION, 0, nil);
            // первый пункт меню
            InsertMenu(Menu, indexMenu + 1, MF_STRING or MF_BYPOSITION, idCmdFirst,
              PChar(IDC_TEST1));
            // второй пункт меню
            InsertMenu(Menu, indexMenu + 2, MF_STRING or MF_BYPOSITION, idCmdFirst + 1,
              PChar(IDC_TEST2));
            // разделитель
            InsertMenu(Menu, indexMenu + 3, MF_SEPARATOR or MF_BYPOSITION, 0, nil);
            // указываем сколько пунктов меню мы добавили
            // 2 пункта - т.к. разделители не считаются
            Result := MakeResult(SEVERITY_SUCCESS, FACILITY_NULL, 2);
          end;
        end;
         
        // данная функция срабатывает при нажатии на наш элемент меню
        function TContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult;
        begin
          Result := E_FAIL;
          if (HiWord(Integer(lpici.lpVerb)) <> 0) then Exit;
          Result := NOERROR;
          // Выбор элементов меню идет по возрастающей в том порядке
          // в каком они были добавлены
          case LoWord(lpici.lpVerb) of
          0: // первый элемент меню
             // тут собственно и нужно делать реакцию на нажатие ;)
            MessageBox(lpici.hWnd, PChar(TmpFileNames), PChar(IDC_TEST1 + ' Pressed'), MB_OK);
          1: // второй элемент меню
            MessageBox(lpici.hWnd, PChar(TmpFileNames), PChar(IDC_TEST2 + ' Pressed'), MB_OK);
          else
            Result := E_INVALIDARG;
          end;
        end;
         
        // Данная функция вызывается когда статус бар в эксплорере активен
        // и в нем отображается краткая информация о подсвеченном пункте меню
        function TContextMenu.GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
          pszName: LPSTR; cchMax: UINT): HRESULT;
        begin
          Result := S_OK;
          if uType = GCS_HELPTEXT then
            case idCmd of
              0:
              begin
                StrCopy(pszName, 'Справочная информация по первому пункту меню');
              end;
              1:
              begin
                StrCopy(pszName, 'Справочная информация по второму пункту меню');
              end
              else
                Result := E_INVALIDARG
            end
        end;
         
        type
          TContextMenuFactory = class(TComObjectFactory)
          public
            procedure UpdateRegistry(Register: Boolean); override;
          end;
         
        // Это процедура которая будет выполнятся при вызове библиотеки из командной строки
        // regsvr32   C:\CONTMENU.dll  - регистрация библиотеки
        // regsvr32   C:\CONTMENU.dll -unregister - снятие библиотеки с регистрации
        procedure TContextMenuFactory.UpdateRegistry(Register: Boolean);
        var
          ClassID: string;
        begin
          if Register then
          begin
            inherited UpdateRegistry(Register);
         
            ClassID := GUIDToString(Class_ContextMenu);
            CreateRegKey('Test\shellex', '', '');
            CreateRegKey('Test\shellex\ContextMenuHandlers', '', '');
            CreateRegKey('Test\shellex\ContextMenuHandlers\ContMenu', '', ClassID);
         
            if (Win32Platform = VER_PLATFORM_WIN32_NT) then
              with TRegistry.Create do
              try
                RootKey := HKEY_LOCAL_MACHINE;
                OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions', True);
                OpenKey('Approved', True);
                WriteString(ClassID, 'Test Context Menu Shell Extension');
              finally
                Free;
              end;
          end
          else
          begin
            DeleteRegKey('Test\shellex\ContextMenuHandlers\ContMenu');
            DeleteRegKey('Test\shellex\ContextMenuHandlers');
            DeleteRegKey('Test\shellex');
            inherited UpdateRegistry(Register);
          end;
        end;
         
        initialization
          TContextMenuFactory.Create(ComServer, TContextMenu, Class_ContextMenu,
            '', 'Test Context Menu Shell Extension', ciMultiInstance,
            tmApartment);
        end.


      Вот и все, компилишь этот код и у тебя готовый ком сервер...
      Регистрировать билиотеку из своей программы так:

      ExpandedWrap disabled
        // Установка...
        procedure TForm1.btnRegClick(Sender: TObject);
        begin
          with TRegistry.Create do
          try
            RootKey := HKEY_CLASSES_ROOT;
            OpenKey('CLSID\{45C15F61-ACAD-48C6-8D86-321ED8A6CFC6}\InprocServer32', True);
            WriteString('','C:\CONTMENU.dll');
            WriteString('ThreadingModel','Apartment');
            CloseKey;
          finally
            Free;
          end;
         
          with TRegistry.Create do
          try
            RootKey := HKEY_LOCAL_MACHINE;
            OpenKey('SOFTWARE\Classes\CLSID\{45C15F61-ACAD-48C6-8D86-321ED8A6CFC6}\InprocServer32', True);
            WriteString('','C:\CONTMENU.dll');
            WriteString('ThreadingModel','Apartment');
            CloseKey;
          finally
            Free;
          end;
         
          with TRegistry.Create do
          try
            RootKey := HKEY_LOCAL_MACHINE;
            OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved', True);
            WriteString('{45C15F61-ACAD-48C6-8D86-321ED8A6CFC6}', 'Test Context Menu Shell Extension');
            CloseKey;
          finally
            Free;
          end;
         
          with TRegistry.Create do
          try
            RootKey := HKEY_CLASSES_ROOT;
            OpenKey('*\shellex\ContextMenuHandlers\Test', True);
            WriteString('','{45C15F61-ACAD-48C6-8D86-321ED8A6CFC6}');
            CloseKey;
          finally
            Free;
          end;
         
          with TRegistry.Create do
          try
            RootKey := HKEY_CLASSES_ROOT;
            OpenKey('Folder\shellex\ContextMenuHandlers\Test', True);
            WriteString('','{45C15F61-ACAD-48C6-8D86-321ED8A6CFC6}');
            CloseKey;
          finally
            Free;
          end;
        end;


      а снимать с регистрации вот так:

      ExpandedWrap disabled
        // Удаление ...
        procedure TForm1.btnUnRegClick(Sender: TObject);
        begin    
          with TRegistry.Create do
          try
            RootKey := HKEY_CLASSES_ROOT;
            OpenKey('CLSID', True);
            DeleteKey('{45C15F61-ACAD-48C6-8D86-321ED8A6CFC6}');
            CloseKey;
          finally
            Free;
          end;
         
          with TRegistry.Create do
          try
            RootKey := HKEY_LOCAL_MACHINE;
            OpenKey('SOFTWARE\Classes\CLSID', True);
            DeleteKey('{45C15F61-ACAD-48C6-8D86-321ED8A6CFC6}');
            CloseKey;
          finally
            Free;
          end;
         
          with TRegistry.Create do
          try
            RootKey := HKEY_LOCAL_MACHINE;
            OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved', True);
            DeleteValue('{45C15F61-ACAD-48C6-8D86-321ED8A6CFC6}');
            CloseKey;
          finally
            Free;
          end;
         
          with TRegistry.Create do
          try
            RootKey := HKEY_CLASSES_ROOT;
            OpenKey('*\shellex\ContextMenuHandlers', True);
            DeleteKey('Test');
            CloseKey;
          finally
            Free;
          end;
         
          with TRegistry.Create do
          try
            RootKey := HKEY_CLASSES_ROOT;
            OpenKey('Folder\shellex\ContextMenuHandlers', True);
            DeleteKey('Test');
            CloseKey;
          finally
            Free;
          end;
        end;


      Если нужно, чтобы пункты меню возникали только для определенных типов файлов, то при вызове QueryContextMenu нужно проверить какие файлы находятся в TmpFileNames, если данные типы файлов не подходят, то выходить из процедуры с результатом
      ExpandedWrap disabled
        Result := MakeResult(SEVERITY_SUCCESS, FACILITY_NULL, 0);



      Автор: Rouse_
      0 пользователей читают эту тему (0 гостей и 0 скрытых пользователей)
      0 пользователей:


      Рейтинг@Mail.ru
      [ Script execution time: 0,0346 ]   [ 17 queries used ]   [ Generated: 28.03.24, 11:22 GMT ]