|
|
Регистрация | << Правила форума >> | FAQ | Пользователи | Календарь | Поиск | Сообщения за сегодня | Все разделы прочитаны |
|
Опции темы | Поиск в этой теме | Опции просмотра |
#1
|
||||
|
||||
Файловые ассоциации - Не все так просто как кажется
Приветствую, помогите реализовать задачу: необходимо мою программу UnMaskFile добавить в контекстное меню всех файлов в системе, перерыл многое, в результате нашел, что якобы это реализуется через написание соответствующей библиотеки, так ли это и нет ли у кого примера?
Вот мой юнит, собранный на основе информации с форумов, для ассоциации программы с указанным типом: Код:
unit Assoc;//Warning Assoc Replaced interface uses Registry, ShlObj, SysUtils, Windows; function RegisterFileType(cMyExt, cMyFileType, cMyDescription, cMyText, ExeName: string; IcoIndex: integer; DoUpdate: boolean = True; cHKEY: HKEY = HKEY_CLASSES_ROOT): boolean; procedure SimpleCreateAssoc(cMyExt, cMyText, ExeName: string); implementation // HKEY_LOCAL_MACHINE\Software\Classes // HKEY_CURRENT_USER\Software\Classes -> for Vista & 7 function RegisterFileType(cMyExt, cMyFileType, cMyDescription, cMyText, ExeName: string; IcoIndex: integer; DoUpdate: boolean = True; cHKEY: HKEY = HKEY_CLASSES_ROOT): boolean; var Reg: TRegistry; Ext: String; begin RESULT := FALSE; // Reg := TRegistry.Create; try Reg.RootKey := cHKEY; // Ext := cMyExt; if Ext[1] <> '*' then begin if Ext[1] <> '.' then Ext := '.' + Ext; end; // if (cHKEY = HKEY_LOCAL_MACHINE) or (cHKEY = HKEY_CURRENT_USER) then Ext := 'Software\Classes\' + Ext; // if Reg.OpenKey(Ext, True) then begin Reg.WriteString('', cMyFileType); // ExeFile or EXE.MyApp Reg.CloseKey; end; // if Reg.OpenKey(cMyFileType, True) then begin Reg.WriteString('', cMyDescription); Reg.CloseKey; end; // if Reg.OpenKey(cMyFileType + '\DefaultIcon', True) then begin Reg.WriteString('', AnsiQuotedStr(ExeName, '"') + ',' + IntToStr(IcoIndex) ); // or: // Reg.WriteString('', AnsiQuotedStr(ExeName + ',' + IntToStr(IcoIndex), '"')); Reg.CloseKey; end; // if Reg.OpenKey(cMyFileType + '\Shell\Open', True) then begin Reg.WriteString('', cMyText); // &Open Reg.CloseKey; end; // if Reg.OpenKey(cMyFileType + '\Shell\Open\Command', True) then begin Reg.WriteString('', AnsiQuotedStr(ExeName, '"') + ' "%1"'); Reg.CloseKey; RESULT := True; end; // if DoUpdate then SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil); // finally Reg.Free; end; end; procedure SimpleCreateAssoc(cMyExt, cMyText, ExeName: string); begin RegisterFileType(cMyExt, cMyExt + 'file', '', cMyText, ExeName, 0, True, HKEY_CLASSES_ROOT); RegisterFileType(cMyExt, cMyExt + 'file', '', cMyText, ExeName, 0, True, HKEY_LOCAL_MACHINE); RegisterFileType(cMyExt, cMyExt + 'file', '', cMyText, ExeName, 0, True, HKEY_CURRENT_USER); end; end. |
#2
|
|||
|
|||
в поставке Дельфи есть пример реализации ShellExtention, в котором делается меню для файлов .dpr. Собственно, для dpr там делается внутри, так что можно брать этот пример, только гуиды новые сгенери.
|
#3
|
||||
|
||||
Цитата:
В моей урезанной поставке такого нету, не могли ли Вы скинуть сорс, кстати у меня Д2010 ? И еще вопрос, как переделать этот сорс под все файлы в системе, вне зависимости от расширения ? |
#4
|
|||
|
|||
Двно было, так что особо не помню, но там как раз вешалось на все файлы, а показывать или нет - в зависимости от конкретного файла.
А вообще, гугл рулит!!! http://web.archive.org/web/200503191...cles/DbD47.asp |
#5
|
||||
|
||||
Цитата:
Спасибо, плохо искал видать |
#6
|
||||
|
||||
Приветствую, по указанной выше ссылке собрал тестовый проект, немного модифицировав, но он так и не заработал, эксперты, ткните плиз носом в ошибки
Код:
unit shellextmain; interface uses Windows, Forms, StdCtrls, ShellApi, SysUtils, Classes, Controls, ComServ, ComObj, ShlObj, ActiveX; //const var CLSID_MainContextMenu: TGUID; ID: String; //= '{F169D961-B907-11D0-B8FA-A85800C10000}';//Генерировать уникальный type TMainContextMenu = class( TComObject, IShellExtInit, IContextMenu ) private FFileName: string; public // IShellExtInit Methods // Use a Method Resolution Clause because Initialize is // defined as a virtual method in TComObject function IShellExtInit.Initialize = ShellInit; function ShellInit( Folder: PItemIDList; DataObject: IDataObject; ProgID: HKEY ): HResult; stdcall; // IContextMenu Methods function QueryContextMenu( Menu: HMENU; Index, CmdFirst, CmdLast, Flags: UINT ): HResult; stdcall; function GetCommandString( Cmd, Flags: UINT; Reserved: PUINT; Name: LPSTR; MaxSize: UINT ): HResult; stdcall; function InvokeCommand( var CommandInfo: TCMInvokeCommandInfo ): HResult; stdcall; end; implementation uses Registry; {==================================} {== TFormViewContextMenu Methods ==} {==================================} function TMainContextMenu.ShellInit( Folder: PItemIDList; DataObject: IDataObject; ProgID: HKEY ): HResult; var Medium: TStgMedium; FE: TFormatEtc; begin if DataObject = nil then begin Result := E_FAIL; Exit; end; with FE do begin cfFormat := CF_HDROP; ptd := nil; dwAspect := DVASPECT_CONTENT; lindex := -1; tymed := TYMED_HGLOBAL; end; // Transfer the data referenced by the IDataObject reference to // an HGLOBAL storage medium in CF_HDROP format. Result := DataObject.GetData( FE, Medium ); if Failed( Result ) then Exit; try // If only one file is selected, retrieve the file name and // store it in FileName. Otherwise fail. if DragQueryFile( Medium.hGlobal, $FFFFFFFF, nil, 0) = 1 then begin SetLength( FFileName, MAX_PATH ); DragQueryFile( Medium.hGlobal, 0, PChar(FFileName), MAX_PATH); Result := NOERROR; end else Result := E_FAIL; finally ReleaseStgMedium( Medium ); end; end; function TMainContextMenu.QueryContextMenu( Menu: HMENU; Index, CmdFirst, CmdLast, Flags: UINT ): HResult; var MenuText: string; AddMenuItem: Boolean; begin AddMenuItem := True; if ( Flags and $000F ) = CMF_NORMAL then MenuText := 'Сканировать с помощью UnMaskFile' else if ( Flags and CMF_VERBSONLY ) <> 0 then MenuText := 'Сканировать с помощью UnMaskFile' else if ( Flags and CMF_EXPLORE ) <> 0 then MenuText := 'Сканировать с помощью UnMaskFile' else AddMenuItem := False; if AddMenuItem then begin InsertMenu( Menu, Index, mf_String or mf_ByPosition, CmdFirst, PChar( MenuText ) ); Result := 1; // Return number of menu items added end else Result := NOERROR; end; {= TMainContextMenu.QueryContextMenu =} function TMainContextMenu.GetCommandString( Cmd, Flags: UINT; Reserved: PUINT; Name: LPSTR; MaxSize: UINT ): HResult; begin case Cmd of 0: begin if Flags = GCS_HELPTEXT then begin // Return the string to be displayed in the Explorer // status bar when the menu item is selected StrCopy(Name, 'Сканировать выбранные файлы с помощью UnMaskFile'); end; Result := NOERROR; end; else // Invalid menu item Result := E_INVALIDARG; end; end; {= TMainContextMenu.GetCommandString =} function GetViewerPath: string; var R: TRegIniFile; begin R := TRegIniFile.Create( '\Software\PAV Team\UnMaskFile' ); try Result := R.ReadString( 'Program', 'Path', '' ); Result := '"' + Result + '" "%s"'; finally R.Free; end; end; function GetGUID: string; var R: TRegIniFile; begin R := TRegIniFile.Create( '\Software\PAV Team\UnMaskFile' ); try Result := R.ReadString( 'Program', 'GUID', '' ); //Result := '"' + Result + '" "%s"'; finally R.Free; end; end; procedure WriteGUID(Val: String); var R: TRegIniFile; begin R := TRegIniFile.Create( '\Software\PAV Team\UnMaskFile' ); try R.WriteString( 'Program', 'GUID', Val ); //Result := '"' + Result + '" "%s"'; finally R.Free; end; end; function MainCreateGuid: TGUID{string}; var ID: TGUID; begin //Result := ''; if {Co}CreateGuid(ID) = S_OK then Result := {GUIDToString(}ID{)}; end; function TMainContextMenu.InvokeCommand( var CommandInfo: TCMInvokeCommandInfo ): HResult; var Success: Boolean; CmdLine: string; SI: TStartupInfo; PI: TProcessInformation; begin // Make sure we are not being called by an application if HiWord( Integer( CommandInfo.lpVerb ) ) <> 0 then begin Result := E_FAIL; Exit; end; // Execute the command specified by CommandInfo.lpVerb case LoWord( CommandInfo.lpVerb ) of 0: begin FillChar( SI, SizeOf( SI ), #0 ); SI.cb := SizeOf( SI ); SI.wShowWindow := sw_ShowNormal; SI.dwFlags := STARTF_USESHOWWINDOW; CmdLine := Format( GetViewerPath, [ FFileName ] ); Success := CreateProcess( nil, PChar( CmdLine ), nil, nil, True, 0, nil, nil, SI, PI ); if not Success then begin MessageBox( CommandInfo.hWnd, 'Ошибка запуска UnMaskFile', 'Ошибка', mb_IconError or mb_OK ); end; Result := NOERROR; end; else // Invalid menu item Result := E_INVALIDARG; end; { case } end; {= TMainContextMenu.InvokeCommand =} initialization // Create a COM object factory which will be responsible for // creating instances of our shell extension. ComServer is // declared in ComServ unit. ID := GetGUID; CLSID_MainContextMenu := StringToGUID(ID); if ID = '' then begin CLSID_MainContextMenu := MainCreateGuid; WriteGUID(GUIDToString(CLSID_MainContextMenu)); end; TComObjectFactory.Create( ComServer, TMainContextMenu, CLSID_MainContextMenu, '', 'Сканирование файлов на наличие вредоносного ПО', ciMultiInstance ); end. ................................................................... library shellext; uses ComServ, shellextmain in 'shellextmain.pas'; exports DllGetClassObject, DllCanUnloadNow, DllRegisterServer, DllUnregisterServer; begin end. ............................................................... unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; procedure Button1Click(Sender: TObject); procedure FormCreate(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.dfm} uses Registry, ShlObj; const MainDllName = 'shellext.dll'; var MainClassID: String; procedure WriteViewerPath; var R: TRegIniFile; begin R := TRegIniFile.Create('\Software\PAV Team\UnMaskFile'); try R.WriteString('Program', 'Path', ParamStr(0)); finally R.Free; end; end; function GetGUID: string; var R: TRegIniFile; begin R := TRegIniFile.Create('\Software\PAV Team\UnMaskFile'); try Result := R.ReadString('Program', 'GUID', ''); //Result := '"' + Result + '" "%s"'; finally R.Free; end; end; procedure WriteGUID(Val: String); var R: TRegIniFile; begin R := TRegIniFile.Create('\Software\PAV Team\UnMaskFile'); try R.WriteString('Program', 'GUID', Val); //Result := '"' + Result + '" "%s"'; finally R.Free; end; end; function MainCreateGuidString: string; var ID: TGUID; begin Result := ''; if CreateGuid(ID) = S_OK then//CoCreateGuid(Guid) - ActiveX Result := GUIDToString(ID); end; procedure TForm1.Button1Click(Sender: TObject); var Reg: TRegistry; begin WriteViewerPath; // MainClassID := GetGUID; if MainClassID = '' then begin MainClassID := MainCreateGuidString; WriteGUID(MainClassID); end; // Reg := TRegistry.Create; try with Reg do begin RootKey := HKEY_CLASSES_ROOT; if OpenKey('\CLSID\' + MainClassID, True) then//{3430BCB6-1F4B-49E7-92C2-FFFE8FF373C2} begin WriteString('', 'UnMaskFile Context Menu Shell Extension'); CloseKey; end; if OpenKey('\CLSID\' + MainClassID + '\InProcServer32', True) then begin WriteString('', ExtractFilePath(ParamStr(0)) + MainDllName); WriteString('ThreadingModel', 'Apartment'); CreateKey('\UnMaskFile\shellex\ContextMenuHandlers\' + MainClassID); CloseKey; end; end; finally Reg.Free; end; SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil); end; procedure TForm1.FormCreate(Sender: TObject); begin if ParamCount > 0 then ShowMessage(ParamStr(1) + #13#10 + ParamStr(2)); end; end. |
#7
|
||||
|
||||
Никто не сталкивался с этим делом?
|