unit shellextmain;
interface
uses
Windows, Forms, StdCtrls, ShellApi, SysUtils, Classes, Controls,
ComServ, ComObj, ShlObj, ActiveX;
var
CLSID_MainContextMenu: TGUID;
ID: String;
type
TMainContextMenu = class( TComObject,
IShellExtInit, IContextMenu )
private
FFileName: string;
public
function IShellExtInit.Initialize = ShellInit;
function ShellInit( Folder: PItemIDList;
DataObject: IDataObject;
ProgID: HKEY ): HResult; stdcall;
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;
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;
Result := DataObject.GetData( FE, Medium );
if Failed( Result ) then
Exit;
try
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;
end
else
Result := NOERROR;
end;
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
StrCopy(Name, 'Сканировать выбранные файлы с помощью UnMaskFile');
end;
Result := NOERROR;
end;
else
Result := E_INVALIDARG;
end;
end;
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', '' );
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 );
finally
R.Free;
end;
end;
function MainCreateGuid: TGUID;
var
ID: TGUID;
begin
if CreateGuid(ID) = S_OK then
Result := ID;
end;
function TMainContextMenu.InvokeCommand( var CommandInfo:
TCMInvokeCommandInfo ): HResult;
var
Success: Boolean;
CmdLine: string;
SI: TStartupInfo;
PI: TProcessInformation;
begin
if HiWord( Integer( CommandInfo.lpVerb ) ) <> 0 then
begin
Result := E_FAIL;
Exit;
end;
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
Result := E_INVALIDARG;
end;
end;
initialization
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
public
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', '');
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);
finally
R.Free;
end;
end;
function MainCreateGuidString: string;
var
ID: TGUID;
begin
Result := '';
if CreateGuid(ID) = S_OK then
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
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.
14.06.2010, 21:30
Файловые ассоциации - Не все так просто как кажется
Линейный вид
