Форум: "WinAPI";
Текущий архив: 2007.11.04;
Скачать: [xml.tar.bz2];

Вниз

добавление пункта в контекстное мен. проводника   Найти похожие ветки 

← →
webpauk   (2007-04-28 18:40) [0]

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

всё работает, только имя файла режется при передаче на первом же пробеле

привожу код ниже

unit SendToDogovorEx;

interface

uses
 Classes, ComServ, ComObj, ActiveX, Windows, ShlObj, Menus, ShellAPI, SysUtils, Registry, Dialogs;

type
 TContextMenuFactory = class(TComObjectFactory)
 public
   procedure UpdateRegistry(Register: Boolean); override;
 end;

 TContextMenu = class(TComObject, IShellExtInit, IContextMenu)
 private
   function BuildSubMenu(Menu: HMENU; IndexMenu: Integer; var IDCmdFirst: Integer): HMENU;
 protected
   szFile: array[0..MAX_PATH] of Char;
   function IShellExtInit.Initialize = IShellExtInit_Initialize;
 public
   function IShellExtInit_Initialize(pidlFolder: PItemIDList; lpdobj:
   IDataObject;
   hKeyProgID: HKEY): HResult; stdcall;

   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;

const
 Class_ContextMenu: TGUID = "{EBDF1F20-C829-11D1-8233-0020AF3E97A9}";
var
 GFileExtensions: TStringList;

const
 MenuCommandStrings: array[0..1] of string = ("", "&Çàðåãèñòðèðîâ àòü äîêóìåíò");

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 + "\Dogovor", 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\SendToDogovor", "", GUIDToString(Class_ContextMenu));
   CreateRegKey("CLSID\" + GUIDToString(ClassID) + "\" + ComServer.ServerKey, "ThreadingModel", "Apartment");
 end
 else
 begin
   DeleteRegKey("*\ShellEx\ContextMenuHandlers\SendToDogovor");
 end;
end;

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;
begin
 with fe do
 begin
   cfFormat:=CF_HDROP;
   ptd:=nil;
   dwAspect:=DVASPECT_CONTENT;
   lindex:=-1;
   tymed:=TYMED_HGLOBAL;
 end;

 if lpdobj = nil then
 begin
   Result:=E_FAIL;
   Exit;
 end;

 Result:=lpdobj.GetData(fe, medium);
 if Failed(Result) then Exit;

 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
 idLastCommand: Integer;
begin
 Result:=E_FAIL;
 idLastCommand:=idCmdFirst;

 BuildSubMenu(Menu, indexMenu, idLastCommand);
 Result:=idLastCommand - idCmdFirst;
end;

function TContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult;
var
 idCmd: UINT;
 fS: String;
begin
 if HIWORD(Integer(lpici.lpVerb)) <> 0 then Result:=E_FAIL
 else
 begin
   idCmd:=LOWORD(lpici.lpVerb);
   Result:=S_OK;

   fS:=szFile;

   case idCmd of
     1: ShellExecute(GetDesktopWindow, "Open", Pchar((ReadDefaultPath)), Pchar(" "+fS+" "), Pchar(ExtractFileDir(ReadDefaultPath)), SW_SHOW);
   end;
 end;
end;

function TContextMenu.GetCommandString(idCmd, uType: UINT; pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult;
begin
 Result:=S_OK;
end;

initialization
 TContextMenuFactory.Create(ComServer, TContextMenu, Class_ContextMenu, "ContextMenu", "Send To Dogovor", ciMultiInstance);
 GFileExtensions:=TStringList.Create;
finalization
 GFileExtensions.Free;
end.


---

← →
TRUNK ©   (2007-05-02 10:12) [1]

Вместо PChar(" "+fS+" ")
напиши PChar(" ""+fS+"" ")

---

← →
webpauk   (2007-05-03 14:34) [2]

методом научного тыка определил:
PChar(" ""+fS+"" " "")

---

← →
webpauk   (2007-05-03 14:56) [3]

library SendToDogovor;

uses
 ComServ,
 SendToDogovorEx in "SendToDogovorEx.pas";

exports
 DllGetClassObject,
 DllCanUnloadNow,
 DllRegisterServer,
 DllUnregisterServer;
begin

end.

создаю dll
регистрирую её через командную строку: regsvr32.exe sendtodogovor.dll
а как зарегистрить без комстроки?

---

← →
TRUNK ©   (2007-05-03 15:39) [4]

> [3] webpauk   (03.05.07 14:56)
> а как зарегистрить без комстроки?

Например так:

function RegisterMyDLL(FileName: string): Boolean;
type
TSimpleProc = function: HResult; stdcall;
var
LH: Cardinal;
DllRegisterServerProc: TSimpleProc;
begin
Result := false;
if (FileName = "") then
 Exit;
LH := LoadLibrary(PChar(FileName));
if (LH = 0) then
 Exit;
try
 @DllRegisterServerProc := GetProcAddress(LH,PChar("DllRegisterServer"));
 Result := (DllRegisterServerProc = NOERROR);
finally
 FreeLibrary(LH);
end;
end;


---

Страницы: 1 вся ветка

Форум: "WinAPI";
Текущий архив: 2007.11.04;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.47 MB
Время: 0.045 c