Explorer Context Menu Shell Extension für Win64

[cookie22]

Zitat von JamesTKirk:

Hast du diesen Inprocserver mit Free Pascal gemacht? Könntest in dem Fall deinen Code ja der FPC Community zur Verfügung stellen, vielleicht verbessert sich die FPC <-> COM Situation dann mal langsam

Gruß,
Sven

klar kann ich das.

Delphi-Quellcode:

unit ContextM;
{$MODE delphi}

interface

uses
  Windows,
  ActiveX,
  ShlObj;

const
  SID_IShellExtInit = '{000214E8-0000-0000-C000-000000000046}';

type
  {$EXTERNALSYM IShellExtInit}
  IShellExtInit = interface(IUnknown)
    [SID_IShellExtInit]
    function Initialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
      hKeyProgID: HKEY): HResult; stdcall;
  end;

type
  TContextMenu = class(TInterfacedObject, IShellExtInit, IContextMenu)
  private
    FFileName: array[0..MAX_PATH] of Char;
  public

    { 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
  DllRefCount: Integer;
  //hBmp: TBitmap;

implementation

uses
  SysUtils,
  ShellApi,
  Registry;
  //Graphics;

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, 'Lazarus Test...');
      //if hBmp.Handle <> 0 then SetMenuItemBitmaps(Menu, indexMenu, MF_BYPOSITION or MF_CHECKED, hBmp.Handle, hBmp.Handle);
      //SetMenuItemBitmaps schickt den Explorer ins Nirvana, warum auch immer.
      Result := 1;
    end;
end;

function TContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult;
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;
    MessageBox(lpici.hwnd, 'Lazarus test', 'Lazarus Test', 0);
    Result := NOERROR;
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, Class_ContextMenu) then
    Result := TContextMenuFactory.Create.QueryInterface(IID, Obj)
  else
    Result := CLASS_E_CLASSNOTAVAILABLE
end;

initialization
  //hBmp := TBitmap.Create;
  //hBmp.LoadFromFile('C:\vista.bmp');
  DllRefCount := 0;
  TContextMenuFactory.Create;

  //finalization
  //FreeAndNil(hBmp);
end.

hab das hier auf das wesentliche reduziert, so sollte es sich kompilieren lassen. ob das nu ne gute lösung ist, ist die frage. SetMenuItemBitmaps lässt den explorer abstürzen, warum weiss ich nicht. vielleicht hat ja jemand von euch ne idee, wie man das verhindern kann. denn mit bildchen sieht das ganze schon besser aus. auf jeden fall läuft das ganze unter 32 und 64 bit stabil.

ich hätt gerne n 64 bit delphi.

gruß,
cookie