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.