Explorer Context Menu Shell Extension für Win64

[cookie22]

hallo,

ich stehe vor dem problem, dass ich eine 64 bit shell extension brauche, weil ja bekanntlich die 32 bit dlls nicht im 64 bit explorer funktionieren. da dachte ich, ich könnte lazarus dazu benutzen. leider hab ich im web sogut wie nichts dazu gefunden.

kennt sich da jemand von euch aus, bzw hat schon mal sowas mit lazarus oder free pascal geschrieben?

gruss,
cookie

[mimi]

Zitat:

dass ich eine 64 bit shell extension

Meinst du damit das Rechte Maus Tasten Menu, wenn du z.b. unter Windows auf eine Datei klickst welches dann kommt ?
Es gibt ein OpenSoruce Projekt: "Datei Manger". Da könntest du etwas finden.

[Luckie]

Da der Code eiegntlich nichts mit Delphi zu tun hat, da es nur um Windows API-Funktionen geht, sehe ich keinen Grund warum man nicht eine Explorer Shellextension für Delphi als Vorlage nehmen könnte oder eben ein Tutorial für Delphi. Eventuell müsste man es noch etwas an die Syntax von Lazarus anpassen, aber sonst sehe ich da keine Hindernisse.

[cookie22]

leider ist das ganze Com zeugs nicht oder nur teilweise implementiert. darum muss man sich schon sehr verbiegen um ne lauffähige shell extension zu bekommen.

[mimi]

Vermutlich wirst du wohl alles selbst erstellen müssen. Es gibt ein Datei Manager Projekt Ich finde den Link im Moment nicht. Aber Eventuell hilft dir das.

Wenn das nur für Windows sein soll, dürfte so eine Komponente doch kein Problem sein oder ? Mit Hilfe der RegEdit. Das Haupt Problem sehe ich Eigentlich in den Menu Punkt z.b. Öffnen mit. Oder wenn ich auf eine Erweiterungen klicke das dann die Anwendungen kommen mit den die Erweiterungen Verbunden sind.

[Elvis]

Kannst du die Shellextension denn nicht als OutOfProcessServer implementieren?
Dank DCOM-Marshaling sollte das problemlos zwischen x64<>x86 gehen.

In .Net habe ich das schon öfter benutzt. Allerdings keine Shelläxte und hauptsächlich um den Code in .Net schreiben zu können, aber ohne die Runtime in den Prozess zu stopfen.

In Delphi habe ich "damals" nur in-process COM Server geschrieben.
Aber ich denke du solltest den Code fast 1:1 übernehmen können.

[cookie22]

hab zu OutOfProcessServern mit delphi oder lazarus leider so gut wie nix gefunden, womit ich was anfangen konnte. für mich ist dieses ganze com zeug bömische dörfer.

hab mir jetzt n inproc-server zusammen gewurstelt, der funktioniert auch stabil. wär aber auch an der out of process geschichte interessiert, wenn jemand dazu nähere infos hat.

[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

[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