Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue40/COMCorn/UIObjs.pas

Pascal/Delphi Source File | 1998-11-12 | 9.2 KB | 314 lines

unit UIObjs;

interface

uses Windows, ComObj, ShlObj, ActiveX, UtilObjs;

type
  // Base class for all things returned by IShellFolder.GetUIObjectOf
  TBaseUIObject = class(TMultiAggregatedObject)
  private
    FHwndOwner: HWND;
  protected
    function GetFileName(const Guid: TGuid): string;
  public
    constructor Create(Owner: TComObject; HwndOwner: HWND); reintroduce;
    property HwndOwner: HWND read FHwndOwner;
  end;

  // Base class for all UI objects that work with only one object at a time
  TSingleSelectUIObject = class(TBaseUIObject)
  private
    FServGuid: TGUID;
  public
    constructor Create(Owner: TComObject; HwndOwner: HWND; Guid: TGUID); reintroduce;
    property ServGuid: TGUID read FServGuid;
  end;

  TForEachProc = procedure (const Guid: TGUID; Data: Integer) of object;

  // Base class for all UI objects that can work with multi-selected objects
  TMultiSelectUIObject = class(TBaseUIObject)
  private
    FServGuids: array of TGUID;
    function GetServGuid(Index: Integer): TGUID;
  protected
    procedure ForEach(Proc: TForEachProc; Data: Integer);
  public
    constructor Create(Owner: TComObject; HwndOwner: HWND;
      Guids: array of TGUID); reintroduce;
    property ServGuids[Index: Integer]: TGUID read GetServGuid;
  end;

  TContextMenu = class(TMultiSelectUIObject, IContextMenu)
  private
    FMenuIdx: UINT;
    procedure UnregisterProc(const Guid: TGuid; Data: Integer);
    procedure ShowPropertiesProc(const Guid: TGuid; Data: Integer);
  protected
    { IContextMenu methods }
    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;

  TExtractIcon = class(TSingleSelectUIObject, IExtractIcon)
  protected
    { IExtractIcon methods }
    function GetIconLocation(uFlags: UINT; szIconFile: PAnsiChar; cchMax: UINT;
      out piIndex: Integer; out pwFlags: UINT): HResult; stdcall;
    function Extract(pszFile: PAnsiChar; nIconIndex: UINT;
      out phiconLarge, phiconSmall: HICON; nIconSize: UINT): HResult; stdcall;
  end;

implementation

uses ComServ, SysUtils, ShellAPI, Registry, PropForm;

{ TBaseUIObject }

constructor TBaseUIObject.Create(Owner: TComObject; HwndOwner: HWND);
begin
  inherited Create(Owner);
  FHWndOwner := HwndOwner;
end;

function TBaseUIObject.GetFileName(const Guid: TGuid): string;
var
  Reg: TRegistry;
begin
  Result := '';
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CLASSES_ROOT;
    if Reg.OpenKeyReadOnly('CLSID\' + GuidToString(Guid) + '\InprocServer32') or
      Reg.OpenKeyReadOnly('CLSID\' + GuidToString(Guid) + '\LocalServer32') then
      Result := Reg.ReadString('');
  finally
    Reg.Free;
  end;
end;

{ TSingleSelectUIObject }

constructor TSingleSelectUIObject.Create(Owner: TComObject; HwndOwner: HWND;
  Guid: TGUID);
begin
  inherited Create(Owner, HwndOwner);
  FServGuid := Guid;
end;

{ TMultiSelectUIObject }

constructor TMultiSelectUIObject.Create(Owner: TComObject; HwndOwner: HWND;
  Guids: array of TGUID);
var
  I: Integer;
begin
  inherited Create(Owner, HwndOwner);
  SetLength(FServGuids, High(Guids) + 1);
  for I := Low(Guids) to High(Guids) do
    FServGuids[I] := Guids[I];
end;

procedure TMultiSelectUIObject.ForEach(Proc: TForEachProc; Data: Integer);
var
  I: Integer;
begin
  for I := Low(FServGuids) to High(FServGuids) do
    Proc(FServGuids[I], Data);
end;

function TMultiSelectUIObject.GetServGuid(Index: Integer): TGUID;
begin
  Result := FServGuids[Index];
end;

{ TContextMenu }

{ TContextMenu.IContextMenu }

function TContextMenu.QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst,
  idCmdLast, uFlags: UINT): HResult;
begin
  FMenuIdx := idCmdFirst;
  Result := idCmdFirst;
  // Add two menu items to context menu
  if InsertMenu(Menu, FMenuIdx, MF_STRING or MF_BYPOSITION, idCmdFirst,
    'Unregister') then
    Inc(Result);
  if InsertMenu(Menu, FMenuIdx + 1, MF_STRING or MF_BYPOSITION, idCmdFirst + 1,
    'Properties') then
    Inc(Result);
end;

function TContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult;
begin
  Result := S_OK;
  try
    // Make sure we are not being called by an application
    if HiWord(Integer(lpici.lpVerb)) <> 0 then
    begin
      Result := E_FAIL;
      Exit;
    end;
    // Execute the command specified by lpici.lpVerb.
    // Return E_INVALIDARG if we are passed an invalid argument number.
    if LoWord(lpici.lpVerb) = FMenuIdx then
      ForEach(UnregisterProc, 0)
    else if LoWord(lpici.lpVerb) = FMenuIdx + 1 then
      ForEach(ShowPropertiesProc, 0)
    else
      Result := E_INVALIDARG;
  except
    on E: TObject do
      Result := Controller.SafeCallException(E, ExceptAddr);
  end;
end;

function TContextMenu.GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
  pszName: LPSTR; cchMax: UINT): HRESULT;
type
  TStringType = (stVerb, stHelpString);
const
  CommandStrings: array[TStringType, 0..1] of PChar = (
    ('Unregister', 'Properties'),
    ('Unregister the selected COM server(s)',
    'View the properties of the selected COM server(s)'));
var
  StringType: TStringType;
begin
  if pszName = nil then
  begin
    Result := E_POINTER;
    Exit;
  end;
  Result := S_OK;
  try
    StrLCopy(pszName, #0#0, cchMax);  // default to empty string
    if not ((idCmd = FMenuIdx) or (idCmd = FMenuIdx + 1)) then
    begin
      Result := E_INVALIDARG;
      Exit;
    end;
    // check whether shell is asking for verb or a help string
    if uType and GCS_VERB <> 0 then StringType := stVerb
    else if uType and GCS_HELPTEXT <> 0 then StringType := stHelpString
    else Exit;
    // return command string for menu item
    StrLCopy(pszName, CommandStrings[StringType, FMenuIdx - idCmd], cchMax)
  except
    on E: TObject do
      Result := Controller.SafeCallException(E, ExceptAddr);
  end;
end;

type
  TRegProc = function: HResult; stdcall;

procedure TContextMenu.UnregisterProc(const Guid: TGuid; Data: Integer);
const
  SUnregError = 'Unregistration Error';
var
  Server: string;
  Handle: THandle;
  RegProc: TRegProc;
  SI: TStartupInfo;
  PI: TProcessInformation;
begin
  Server := GetFileName(Guid);
  if AnsiCompareText(ExtractFileExt(Server), '.dll') = 0 then
  begin
    Handle := LoadLibrary(PChar(Server));
    if Handle <= HINSTANCE_ERROR then
      MessageBox(HwndOwner, 'Could not load library', SUnregError, MB_OK);
    try
      RegProc := GetProcAddress(Handle, 'DllUnregisterServer');
      if Assigned(RegProc) then OleCheck(RegProc)
      else MessageBox(HwndOwner, 'Couldn''t unregister library', SUnregError, MB_OK);
    finally
      FreeLibrary(Handle);
    end;
  end
  else if AnsiCompareText(ExtractFileExt(Server), '.exe') = 0 then
  begin
    FillChar(SI, SizeOf(SI), 0);
    SI.cb := SizeOf(SI);
    if not CreateProcess(PChar('"' + Server + '"'),
      PChar('"' + Server + '" /unregserver'), nil, nil, True, 0, nil, nil,
      SI, PI) then
      MessageBox(HwndOwner, 'Error executing server', SUnregError, MB_OK)
    else begin
      CloseHandle(PI.hThread);
      CloseHandle(PI.hProcess);
    end;
  end;
end;

procedure TContextMenu.ShowPropertiesProc(const Guid: TGuid;
  Data: Integer);
begin
  ShowRegProps(Guid);
end;

{ TExtractIcon }

function TExtractIcon.Extract(pszFile: PAnsiChar; nIconIndex: UINT;
  out phiconLarge, phiconSmall: HICON; nIconSize: UINT): HResult;
begin
  // This method only needs to be implemented if the icon is stored in
  // some type of user-defined data format.  Since our icon is in a
  // plain old DLL, we just return S_FALSE.
  Result := S_FALSE;
end;

function TExtractIcon.GetIconLocation(uFlags: UINT; szIconFile: PAnsiChar;
  cchMax: UINT; out piIndex: Integer; out pwFlags: UINT): HResult;
var
  Server, IconFile, ToolboxKey: string;
  Reg: TRegistry;
  CommaPos, Code: Integer;
begin
  Result := S_OK;
  pwFlags := GIL_DONTCACHE or GIL_PERINSTANCE;
  try
    Server := GetFileName(ServGuid);
    if AnsiCompareText(ExtractFileExt(Server), '.dll') = 0 then
    begin
      Reg := TRegistry.Create;
      try
        Reg.RootKey := HKEY_CLASSES_ROOT;
        ToolboxKey := 'CLSID\' + GuidToString(ServGuid) + '\ToolboxBitmap32';
        if Reg.KeyExists(ToolboxKey) then
        begin
          Reg.OpenKeyReadOnly(ToolboxKey);
          IconFile := Reg.ReadString('');
          CommaPos := LastDelimiter(',', IconFile);
          if CommaPos > 0 then
          begin
            Val(Copy(IconFile, CommaPos + 1, Length(IconFile)), piIndex, Code);
            if Code = 0 then
            begin
              IconFile[CommaPos] := #0;
              StrLCopy(szIconFile, PChar(IconFile), cchMax);
              Exit;
            end;
          end;
        end;
      finally
        Reg.Free;
      end;
    end;
    StrLCopy(szIconFile, PChar(Server), cchMax);
    piIndex := 0;
  except
    on E: TObject do
      Result := Controller.SafeCallException(E, ExceptAddr);
  end;
end;

end.