unit ContextM2;
interface
uses
Windows,
ActiveX, ComObj, ShlObj, Dialogs,Registry;
type
TContextMenu =
class(TComObject, IShellExtInit, IContextMenu)
private
FFileName:
array[0..MAX_PATH]
of Char;
protected
{ IShellExtInit }
function IShellExtInit.Initialize = SEIInitialize;
// Avoid compiler warning
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;
const
Class_ContextMenu: TGUID = '
{D4B97850-9199-476A-9673-7A269278D226}';
implementation
uses ComServ, SysUtils, ShellApi;
function TContextMenu.SEIInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
hKeyProgID: HKEY): HResult;
var
StgMedium: TStgMedium;
FormatEtc: TFormatEtc;
begin
// Fail the call if lpdobj is Nil.
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;
// Render the data referenced by the IDataObject pointer to an HGLOBAL
// storage medium in CF_HDROP format.
Result := lpdobj.GetData(FormatEtc, StgMedium);
if Failed(Result)
then
Exit;
// If only one file is selected, retrieve the file name and store it in
// FFileName. Otherwise fail the call.
if (DragQueryFile(StgMedium.hGlobal, $FFFFFFFF,
nil, 0) = 1)
then begin
DragQueryFile(StgMedium.hGlobal, 0, FFileName, SizeOf(FFileName));
Result := NOERROR;
end
else begin
FFileName[0] := #0;
Result := E_FAIL;
end;
ReleaseStgMedium(StgMedium);
end;
function TContextMenu.QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst,
idCmdLast, uFlags: UINT): HResult;
begin
Result := 0;
// or use MakeResult(SEVERITY_SUCCESS, FACILITY_NULL, 0);
if ((uFlags
and $0000000F) = CMF_NORMAL)
or
((uFlags
and CMF_EXPLORE) <> 0)
then begin
// Add one menu item to context menu
ShowMessage('
Adding ONE item');
InsertMenu(Menu, indexMenu, MF_STRING
or MF_BYPOSITION, idCmdFirst, '
-> Upload Image');
// Return number of menu items added
Result := 1;
// or use MakeResult(SEVERITY_SUCCESS, FACILITY_NULL, 1)
end;
end;
function TContextMenu.InvokeCommand(
var lpici: TCMInvokeCommandInfo): HResult;
resourcestring
sPathError = '
Error setting current directory';
var
H: THandle;
PrevDir:
string;
regist: TRegistry;
begin
regist:=TRegistry.Create;
regist.RootKey:=HKEY_LOCAL_MACHINE;
regist.OpenKey('
SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\666kb.exe', true);
Result := E_FAIL;
// Make sure we are not being called by an application
if (HiWord(Integer(lpici.lpVerb)) <> 0)
then
begin
Exit;
end;
// Make sure we aren't being passed an invalid argument number
if (LoWord(lpici.lpVerb) <> 0)
then begin
Result := E_INVALIDARG;
Exit;
end;
// Execute the command specified by lpici.lpVerb
// by invoking the Delphi command line compiler.
PrevDir := GetCurrentDir;
try
if not SetCurrentDir(ExtractFilePath(FFileName))
then
raise Exception.CreateRes(@sPathError);
//H := WinExec(PChar(Format(GetCompilerPath, [FFileName])), lpici.nShow);
//ShowMessage(Pchar(regist.ReadString('')+' '+ExtractFilePath(FFileName)+ExtractFileName(FFileName)));
H := WinExec(Pchar(regist.ReadString('
')+'
"'+ExtractFilePath(FFileName)+ExtractFileName(FFileName)+'
"'), lpici.nShow);
if (H < 32)
then
MessageBox(lpici.hWnd, '
Error', '
Error',
MB_ICONERROR
or MB_OK);
Result := NOERROR;
finally
SetCurrentDir(PrevDir);
end;
end;
function TContextMenu.GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
pszName: LPSTR; cchMax: UINT): HRESULT;
begin
if (idCmd = 0)
then begin
if (uType = GCS_HELPTEXT)
then
// return help string for menu item
StrCopy(pszName, '
Compile the selected Delphi project');
Result := NOERROR;
end
else
Result := E_INVALIDARG;
end;
type
TContextMenuFactory =
class(TComObjectFactory)
public
procedure UpdateRegistry(
Register: Boolean);
override;
end;
procedure TContextMenuFactory.UpdateRegistry(
Register: Boolean);
var
ClassID:
string;
begin
if Register then
begin
inherited UpdateRegistry(
Register);
ClassID := GUIDToString(Class_ContextMenu);
// Die Shell-Erweiterung wird hier für Ordner (Folder) registriert
// Der Text DFKontextMenu ist frei wählbar und charakterisier die eigene Erweiterung
//CreateRegKey('Folder\shellex', '', '');
//CreateRegKey('Folder\shellex\ContextMenuHandlers', '', '');
//CreateRegKey('Folder\shellex\ContextMenuHandlers\DFKontextMenu', '', ClassID);
//Die Shell-Erweiterung wird hier für alle Dateien registriert
// ansonsten muss statt des Sterns (alle Dateien) die konkrete Dateiendung
// stehen, z. B. '.zip'
// Der Text DFKontextMenu ist frei wählbar und charakterisier die eigene Erweiterung
CreateRegKey('
.jpg\shellex', '
', '
');
CreateRegKey('
.jpg\shellex\ContextMenuHandlers', '
', '
');
CreateRegKey('
.jpg\shellex\ContextMenuHandlers\ContMenu', '
', ClassID);
CreateRegKey('
.jpeg\shellex', '
', '
');
CreateRegKey('
.jpeg\shellex\ContextMenuHandlers', '
', '
');
CreateRegKey('
.jpeg\shellex\ContextMenuHandlers\ContMenu', '
', ClassID);
CreateRegKey('
.gif\shellex', '
', '
');
CreateRegKey('
.gif\shellex\ContextMenuHandlers', '
', '
');
CreateRegKey('
.gif\shellex\ContextMenuHandlers\ContMenu', '
', ClassID);
CreateRegKey('
.png\shellex', '
', '
');
CreateRegKey('
.png\shellex\ContextMenuHandlers', '
', '
');
CreateRegKey('
.png\shellex\ContextMenuHandlers\ContMenu', '
', ClassID);
CreateRegKey('
.bmp\shellex', '
', '
');
CreateRegKey('
.bmp\shellex\ContextMenuHandlers', '
', '
');
CreateRegKey('
.bmp\shellex\ContextMenuHandlers\ContMenu', '
', ClassID);
// Shell-Erweiterung als "genehmigt" eintragen
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, '
ContMenu');
finally
Free;
end;
end
else
begin
// wird die Shell-Erweiterung wieder entfernt, werden die Einträge der
// Registrierung gelöscht
//hier wird dann irgendwann alles gelöscht *__*
inherited UpdateRegistry(
Register);
end;
end;
initialization
TContextMenuFactory.Create(ComServer, TContextMenu, Class_ContextMenu,
'
', '
Delphi Context Menu Shell Extension Example', ciMultiInstance,
tmApartment);
end.