AGB  ·  Datenschutz  ·  Impressum  







Anmelden
Nützliche Links
Registrieren
Zurück Delphi-PRAXiS Sprachen und Entwicklungsumgebungen Object-Pascal / Delphi-Language Delphi Explorer Shell Extension für Delphi und Free Pascal

Explorer Shell Extension für Delphi und Free Pascal

Offene Frage von "cookie22"
Ein Thema von cookie22 · begonnen am 5. Jul 2009
Antwort Antwort
Benutzerbild von cookie22
cookie22

Registriert seit: 28. Jun 2006
Ort: Düsseldorf
936 Beiträge
 
Delphi XE2 Professional
 
#1

Explorer Shell Extension für Delphi und Free Pascal

  Alt 5. Jul 2009, 08:17
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
  Mit Zitat antworten Zitat
Themen-Optionen Thema durchsuchen
Thema durchsuchen:

Erweiterte Suche
Ansicht

Forumregeln

Es ist dir nicht erlaubt, neue Themen zu verfassen.
Es ist dir nicht erlaubt, auf Beiträge zu antworten.
Es ist dir nicht erlaubt, Anhänge hochzuladen.
Es ist dir nicht erlaubt, deine Beiträge zu bearbeiten.

BB-Code ist an.
Smileys sind an.
[IMG] Code ist an.
HTML-Code ist aus.
Trackbacks are an
Pingbacks are an
Refbacks are aus

Gehe zu:

Impressum · AGB · Datenschutz · Nach oben
Alle Zeitangaben in WEZ +1. Es ist jetzt 03:25 Uhr.
Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
LinkBacks Enabled by vBSEO © 2011, Crawlability, Inc.
Delphi-PRAXiS (c) 2002 - 2023 by Daniel R. Wolf, 2024 by Thomas Breitkreuz