Explorer Shell Extension für Delphi und Free Pascal

[cookie22]

hallo,

ich brauche eine explorer shell extension, die ich in lazarus für win64 compilieren kann.

da habe ich mir gedacht es wäre doch schön, wenn man das ganze nur einmal schreiben müsste und es für delphi(win32) und lazarus(win64) ohne grosse änderungen compilieren kann.

in diesem post steht mehr oder weniger wie es geht: https://forums.embarcadero.com/threa...ssageID=126631

Leider versteh ich da irgendwas nicht richtig oder mache was falsch. Ich poste mal meinen code.

Delphi-Quellcode:

library Project1;

uses
  //ComServ, // Delphi
  ContextM in 'ContextM.pas';

exports
  DllGetClassObject,
  DllCanUnloadNow;
 // DllRegisterServer,      // Delphi
 // DllUnregisterServer;    // Delphi

begin
end.

Delphi-Quellcode:

unit ContextM;
//{$mode delphi}   Fpc

interface

uses
  Windows,
  ActiveX,
  ComObj,
  Graphics,
  ShlObj;
  //Comserv;  // Delphi

type
  TContextMenu = class(TComObject, IShellExtInit, IContextMenu)
  private
    FFileName: array[0..MAX_PATH] of Char;
  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;

function DllGetClassObject(const CLSID, IID: TGUID; var Obj): HResult; stdcall;
function DllCanUnloadNow: HResult; stdcall;

const
  Class_ContextMenu: TGUID = '{EBDF1F20-C829-11D1-8245-0020AF3E97A2}';

var
  hBmp: TBitmap;
  DllRefCount: Integer;

resourcestring
  sPathError = 'Error setting current directory';
implementation

uses SysUtils,
  ShellApi,
  Registry;

function TContextMenu.SEIInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
  hKeyProgID: HKEY): HResult;
var
  StgMedium: TStgMedium;
  FormatEtc: TFormatEtc;

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;
  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);                 //FPC
  ReleaseStgMedium(StgMedium);                    //Delphi
end;

function TContextMenu.QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst,
  idCmdLast, uFlags: UINT): HResult;
begin
  Result := 0;
  if ((uFlags and $0000000F) = CMF_NORMAL) or
    ((uFlags and CMF_EXPLORE) <> 0) then
    begin
      InsertMenu(Menu, indexMenu, MF_STRING or MF_BYPOSITION, idCmdFirst, 'Test');
      if hBmp.Handle <> 0 then SetMenuItemBitmaps(Menu, indexMenu, MF_BYPOSITION, hBmp.Handle, hBmp.Handle); 
      Result := 1;
    end;
end;

function TContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult;
var
  H : THandle;
  PrevDir: string;
begin
  Result := E_FAIL;
  if (HiWord(Integer(lpici.lpVerb)) <> 0) then
    begin
      Exit;
    end;
  if (LoWord(Integer(lpici.lpVerb)) <> 0) then
    begin
      Result := E_INVALIDARG;
      Exit;
    end;
  PrevDir := GetCurrentDir;
  try
    if not SetCurrentDir(ExtractFilePath(FFileName)) then
      raise Exception.CreateRes(@sPathError);
    MessageBox(lpici.hwnd, 'Test', 'Test', 0);
    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
        StrCopy(pszName, 'This is a test');
      Result := NOERROR;
    end
  else
    Result := E_INVALIDARG;
end;

type
  TContextMenuFactory = class(TInterfacedObject, IClassFactory)
    constructor Create;
    destructor Destroy; override;
    function CreateInstance(const unkOuter: IUnknown; const riid: TIID;
      out vObject): HResult; stdcall;
    function LockServer(fLock: BOOL): HResult; stdcall;
  end;

constructor TContextMenuFactory.Create;
begin
  inherited;
  Inc(DllRefCount);
end;

destructor TContextMenuFactory.Destroy;
begin
  Dec(DllRefCount);
  inherited;
end;

function TContextMenuFactory.CreateInstance(const unkOuter: IUnknown;
  const riid: TIID; out vObject): HResult;
begin
  Pointer(vObject) := nil;
  if unkOuter <> nil then
    Result := CLASS_E_NOAGGREGATION
  else
    try
      Result := TContextMenu.Create.QueryInterface(riid, vObject);
    except
      Result := E_OUTOFMEMORY;
    end;
end;

function TContextMenuFactory.LockServer(fLock: BOOL): HResult;
begin
  Result := NOERROR
end;

function DllCanUnloadNow: HResult; stdcall;
begin
  if DllRefCount = 0 then
    Result := S_OK
  else
    Result := S_FALSE
end;

function DllGetClassObject(const CLSID, IID: TGUID; var Obj): HResult; stdcall;
begin
  Pointer(Obj) := nil;
  if IsEqualGUID(CLSID, IID) then
    Result := TContextMenuFactory.Create.QueryInterface(IID, Obj)
  else
    Result := CLASS_E_CLASSNOTAVAILABLE
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);
//    CreateRegKey('*\shellex', '', '');
//    CreateRegKey('*\shellex\ContextMenuHandlers', '', '');
//    CreateRegKey('*\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('*\shellex\ContextMenuHandlers\ContMenu');
//    DeleteRegKey('*\shellex\ContextMenuHandlers');
//    DeleteRegKey('*\shellex');
//    inherited UpdateRegistry(Register);
//  end;
//end;

initialization
  hBmp := TBitmap.Create;
  hBmp.LoadFromFile('C:\vista.bmp');
  DllRefCount := 0;
  //TContextMenuFactory.Create(ComServer, TContextMenu, Class_ContextMenu,
  //    '', 'Test Context Menu Shell Extension', ciMultiInstance, tmApartment);
  TContextMenuFactory.Create;

finalization
  hBmp.Free;
end.

wenn ich das ganze mit ComServ.pas und der auskommentierten TContextMenuFactory compiliere geht alles wie gewohnt von delphi. mache ich es so wie in dem post angegeben, seh ich nix im explorer (die dll ist registriert).

wo könnte der fehler liegen?

danke im voraus für eure hilfe.

gruss,
cookie