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

Pascal/Delphi Source File | 1998-11-10 | 11.0 KB | 356 lines

unit Main;

interface

uses
  Windows, Classes, ActiveX, ComObj, ShlObj, UtilObjs;

type
  TComNameExt = class(TComObject, IShellFolder, IPersistFolder,
    IEnumIDList)
  private
    FServList: TComServerList;
    FShellMalloc: IMalloc;
    property ServList: TComServerList read FServList write FServList implements IEnumIDList;
  protected
    { Method aliases }
    function IPersistFolder.Initialize = PersistFolderInitialize;
    { IShellFolder methods }
    function ParseDisplayName(hwndOwner: HWND;
      pbcReserved: Pointer; lpszDisplayName: POLESTR; out pchEaten: ULONG;
      out ppidl: PItemIDList; var dwAttributes: ULONG): HResult; stdcall;
    function EnumObjects(hwndOwner: HWND; grfFlags: DWORD;
      out EnumIDList: IEnumIDList): HResult; stdcall;
    function BindToObject(pidl: PItemIDList; pbcReserved: Pointer;
      const riid: TIID; out ppvOut: Pointer): HResult; stdcall;
    function BindToStorage(pidl: PItemIDList; pbcReserved: Pointer;
      const riid: TIID; out ppvObj: Pointer): HResult; stdcall;
    function CompareIDs(lParam: LPARAM;
      pidl1, pidl2: PItemIDList): HResult; stdcall;
    function CreateViewObject(hwndOwner: HWND; const riid: TIID;
      out ppvOut: Pointer): HResult; stdcall;
    function GetAttributesOf(cidl: UINT; var apidl: PItemIDList;
      var rgfInOut: UINT): HResult; stdcall;
    function GetUIObjectOf(hwndOwner: HWND; cidl: UINT; var apidl: PItemIDList;
      const riid: TIID; prgfInOut: Pointer; out ppvOut: Pointer): HResult; stdcall;
    function GetDisplayNameOf(pidl: PItemIDList; uFlags: DWORD;
      var lpName: TStrRet): HResult; stdcall;
    function SetNameOf(hwndOwner: HWND; pidl: PItemIDList; lpszName: POLEStr;
      uFlags: DWORD; var ppidlOut: PItemIDList): HResult; stdcall;
    { IPersist method }
    function GetClassID(out classID: TCLSID): HResult; stdcall;
    { IPersistFolder method }
    function PersistFolderInitialize(pidl: PItemIDList): HResult; stdcall;
  public
    destructor Destroy; override;
    procedure Initialize; override;
    procedure RefreshServerList; virtual;
    property ShellMalloc: IMalloc read FShellMalloc;
  end;

  TNamespaceExtensionFactory = class(TComObjectFactory)
  protected
    function GetProgID: string; override;
  public
    procedure UpdateRegistry(Register: Boolean); override;
  end;

const
  Class_ComNameExt: TGUID = '{6CA52791-76C1-11D2-8BFB-00104B700B61}';

implementation

uses ComServ, SysUtils, Registry, ViewObj, UIObjs;

{ TComNameExt }

destructor TComNameExt.Destroy;
begin
  FServList.Free;
  inherited Destroy;
end;

procedure TComNameExt.Initialize;
begin
  inherited Initialize;
  FServList := TComServerList.Create(Self);
  OleCheck(ShGetMalloc(FShellMalloc));    // Squirrel away shell's IMalloc
end;

procedure TComNameExt.RefreshServerList;
var
  Reg: TRegistry;
  I, KeyIdx: Integer;
  ClsidKeys, SubKeys: TStringList;
  CurrentKey: string;
begin
  // This method just reads through the HKEY_CLASSES_ROOT\CLSID registry key,
  // and saves all the COM servers listed under that key to the ServList list.
  Reg := TRegistry.Create;
  ClsidKeys := TStringList.Create;
  try
    ServList.Clear;
    Reg.RootKey := HKEY_CLASSES_ROOT;
    if not Reg.OpenKeyReadOnly('CLSID') then
      raise Exception.Create('Failed to open registry');
    Reg.GetKeyNames(ClsidKeys);  // Get list of registered CLSIDs
    Reg.CloseKey;
    SubKeys := TStringList.Create;
    try
      for I := 0 to ClsidKeys.Count - 1 do  // iterate over all CLSIDs
      begin
        CurrentKey := ClsidKeys[I];
        if Reg.OpenKeyReadOnly('CLSID\' + CurrentKey) then
        begin
          // Make sure this CLSID is a COM server
          Reg.GetKeyNames(SubKeys);
          Reg.CloseKey;
          KeyIdx := SubKeys.IndexOf('InprocServer32');
          if KeyIdx < 0 then KeyIdx := SubKeys.IndexOf('LocalServer32');
          if KeyIdx < 0 then Continue;
          // Add CLSID to list of COM servers
          ServList.AddGuid(StringToGUID(CurrentKey));
        end;
      end;
    finally
      SubKeys.Free;
    end;
  finally
    Reg.Free;
    ClsidKeys.Free;
  end;
end;

{ TComNameExt.IShellFolder }

function TComNameExt.ParseDisplayName(hwndOwner: HWND;
  pbcReserved: Pointer; lpszDisplayName: POLESTR; out pchEaten: ULONG;
  out ppidl: PItemIDList; var dwAttributes: ULONG): HResult;
begin
  Result := E_NOTIMPL;
end;

function TComNameExt.EnumObjects(hwndOwner: HWND; grfFlags: DWORD;
  out EnumIDList: IEnumIDList): HResult;
begin
  Result := S_OK;
  try
    // IEnumIDList implementation methods live in a separate object just
    // because I think that is cleaner.
    EnumIDList := Self as IEnumIDList;
  except
    on E: TObject do
      Result := SafeCallException(E, ExceptAddr);
  end;
end;

function TComNameExt.BindToObject(pidl: PItemIDList; pbcReserved: Pointer;
  const riid: TIID; out ppvOut: Pointer): HResult;
begin
  Result := E_NOTIMPL;
end;

function TComNameExt.BindToStorage(pidl: PItemIDList; pbcReserved: Pointer;
  const riid: TIID; out ppvObj: Pointer): HResult;
begin
  Result := E_NOTIMPL;
end;

function TComNameExt.CompareIDs(lParam: LPARAM;
  pidl1, pidl2: PItemIDList): HResult;
var
  Guids1, Guids2: string;
  IDs1, IDs2: PServInfo;
begin
  // This method does a reasonably cheesey compare of two pidls simply by
  // converting the CLSID portion of my PIDL to a string and using CompareStr.
  try
    IDs1 := PServInfo(pidl1);
    IDs2 := PServInfo(pidl2);
    while IDs1.Size <> 0 do
    begin
      Guids1 := Guids1 + GuidToString(IDs1^.CLSID);
      Inc(IDs1);
    end;
    while IDs2.Size <> 0 do
    begin
      Guids1 := Guids1 + GuidToString(IDs2^.CLSID);
      Inc(IDs2);
    end;
    Result := CompareStr(Guids1, Guids2);  // sort alphabetically
  except
    on E: TObject do
      Result := SafeCallException(E, ExceptAddr);
  end;
end;

function TComNameExt.CreateViewObject(hwndOwner: HWND; const riid: TIID;
  out ppvOut: Pointer): HResult;
begin
  // Return an IShellView pointer when requested.  Remember that this method
  // Can be called many times, so this class must support multiple IShellViews
  // on a single IShellFolder.
  Result := S_OK;
  try
    ppvOut := nil;
    if IsEqualGuid(riid, IShellView) then
      IShellView(ppvOut) := TViewObject.Create(Self, hwndOwner)
    else
      Result := E_NOINTERFACE;
  except
    on E: TObject do
      Result := SafeCallException(E, ExceptAddr);
  end;
end;

function TComNameExt.GetAttributesOf(cidl: UINT; var apidl: PItemIDList;
  var rgfInOut: UINT): HResult;
begin
  if (@rgfInOut = nil) then
  begin
    Result := E_POINTER;
    Exit;
  end;
  rgfInOut := 0;  // pretty boring...
  Result := S_OK;
end;

function TComNameExt.GetUIObjectOf(hwndOwner: HWND; cidl: UINT; var apidl: PItemIDList;
  const riid: TIID; prgfInOut: Pointer; out ppvOut: Pointer): HResult;
var
  Guids: array of TGUID;
  ServInfo: PServInfo;
  I: Integer;
begin
  // Returns an IContextMenu or IExtractIcon when requested.  Like IShellViews,
  // this IShellFolder must support multiple UI objects at one time.
  Result := S_OK;
  ppvOut := nil;
  try
    SetLength(Guids, cidl);
    ServInfo := PServInfo(apidl);
    // Store the GUIDs for each pidl in an array
    for I := 0 to cidl - 1 do
    begin
      Guids[I] := ServInfo.CLSID;
      Inc(ServInfo);
    end;
    if IsEqualGuid(riid, IContextMenu) then
    begin
       IContextMenu(ppvOut) := TContextMenu.Create(Self, hwndOwner, Guids);
    end
    else if IsEqualGuid(riid, IExtractIcon) then
    begin
       IExtractIcon(ppvOut) := TExtractIcon.Create(Self, hwndOwner, Guids[0]);
    end
    else begin
      Result := E_NOINTERFACE;
      Exit;
    end;
  except
    on E: TObject do
      Result := SafeCallException(E, ExceptAddr);
  end;
end;

function TComNameExt.GetDisplayNameOf(pidl: PItemIDList; uFlags: DWORD;
  var lpName: TStrRet): HResult;
var
  Guid: TGUID;
  NameStr, GuidStr: string;
  Reg: TRegistry;
begin
  // Looks to the registry to find the name of a particular COM server
  Result := S_OK;
  try
    FillChar(lpName, SizeOf(lpName), 0);
    Guid := PServInfo(pidl)^.CLSID;
    GuidStr := GuidToString(Guid);
    lpName.uType := STRRET_CSTR;
    if HiWord(uFlags) and (SHGDN_FORPARSING) = 0 then
    begin
      Reg := TRegistry.Create;
      Reg.RootKey := HKEY_CLASSES_ROOT;
      Reg.OpenKeyReadOnly('CLSID\' + GuidStr);
      NameStr := Reg.ReadString('');
    end;
    if NameStr = '' then NameStr := GuidStr;
    StrLCopy(lpName.cStr, PChar(NameStr), SizeOf(lpName.cStr));
  except
    on E: TObject do
      Result := SafeCallException(E, ExceptAddr);
  end;
end;

function TComNameExt.SetNameOf(hwndOwner: HWND; pidl: PItemIDList; lpszName: POLEStr;
  uFlags: DWORD; var ppidlOut: PItemIDList): HResult;
begin
  Result := E_NOTIMPL;
end;

{ TComNameExt.IPersist }

function TComNameExt.GetClassID(out classID: TCLSID): HResult;
begin
  classID := Class_ComNameExt;
  Result := S_OK;
end;

{ TComNameExt.IPersistFolder }

function TComNameExt.PersistFolderInitialize(pidl: PItemIDList): HResult;
begin
  Result := S_OK;  // Don't care where we where initialized
end;

{ TNamespaceExtensionFactory }

function TNamespaceExtensionFactory.GetProgID: string;
begin
  // ProgID not required for namespace extension
  Result := '';
end;

procedure TNamespaceExtensionFactory.UpdateRegistry(Register: Boolean);
const
  NamespaceKey = 'SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\' +
    'MyComputer\Namespace\';
  ApproveKey = 'SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved\';
var
  ClsID: string;
  Value: DWORD;
begin
  ClsID := GUIDToString(Class_ComNameExt);
  inherited UpdateRegistry(Register);
  if Register then
  begin
    // Junction for this amespace extension is "My Computer"
    CreateRegKeyEx(NameSpaceKey + ClsId, '', PChar(Description), REG_SZ,
      Length(Description) + 1, HKEY_LOCAL_MACHINE);
    // Shell extension must be approved under NT
    if Win32Platform = VER_PLATFORM_WIN32_NT then
      CreateRegKeyEx(ApproveKey, ClsId, PChar(Description), REG_SZ,
        Length(Description) + 1, HKEY_LOCAL_MACHINE);
    // Write "Folder" attribute to registry
    Value := SFGAO_FOLDER;
    CreateRegKeyEx('CLSID\' + ClsId + '\ShellFolder\', 'Attributes',
      @Value, REG_BINARY, SizeOf(DWORD), HKEY_CLASSES_ROOT);
    // Default icon is contained within this file
    CreateRegKey('CLSID\' + ClsId + '\DefaultIcon', '',
      ComServer.ServerFileName + ',0');
  end
  else begin
    // Remove junction
    RegDeleteKey(HKEY_LOCAL_MACHINE, PChar(NameSpaceKey + ClsId));
    // Remove approval on NT
    if Win32Platform = VER_PLATFORM_WIN32_NT then
      DeleteRegValue(ApproveKey, ClsId, HKEY_LOCAL_MACHINE);
  end;
end;

initialization
  TNamespaceExtensionFactory.Create(ComServer, TComNameExt, Class_ComNameExt,
    'ComNameExt', 'Registered COM objects', ciMultiInstance,
    tmApartment);
end.