{ *********************************************************************** }
{                                                                         }
{ Translated Header File                                                  }
{ Part of the Delphi Visual Component Library                             }
{                                                                         }
{ Original Header File Copyright (c) 1985-2004 Microsoft Corporation      }
{  All Rights Reserved.                                                   }
{                                                                         }
{ Translation Copyright (c) 1995-2004 Borland Software Corporation        }
{                                                                         }
{ *********************************************************************** }

{*******************************************************}
{       COM object support                              }
{*******************************************************}

unit Borland.Vcl.ComObj platform;

interface

uses
  System.Runtime.InteropServices,
  Windows, ActiveX, Variants, SysUtils;

type
{ OLE exception classes }

  EOleError = class(Exception);

  EOleSysError = class(EOleError)
  private
    FErrorCode: HRESULT;
  public
    constructor Create(const Message: string; ErrorCode: HRESULT;
      HelpContext: Integer);
    property ErrorCode: HRESULT read FErrorCode write FErrorCode;
  end;

  EOleRegistrationError = class(EOleError);

function CreateComObject(const ClassID: TGUID): TObject;
function CreateRemoteComObject(const MachineName: WideString; const ClassID: TGUID): TObject;
procedure OleError(ErrorCode: HResult);
procedure OleCheck(Result: HResult);
function ProgIDToClassID(const ProgID: string): TGUID;
function ClassIDToProgID(const ClassID: TGUID): string;

procedure CreateRegKey(const Key, ValueName, Value: string; RootKey: DWord = HKEY_CLASSES_ROOT);
procedure DeleteRegKey(const Key: string; RootKey: DWord = HKEY_CLASSES_ROOT);
function GetRegStringValue(const Key, ValueName: string; RootKey: DWord = HKEY_CLASSES_ROOT): string;

implementation

uses
  System.Text, ComConst;

const
  IID_IUnknown = '00000000-0000-0000-C000-000000000046';

{ EOleSysError }

constructor EOleSysError.Create(const Message: string;
  ErrorCode: HRESULT; HelpContext: Integer);
var
  S: string;
begin
  S := Message;
  if S = '' then
  begin
    S := SysErrorMessage(ErrorCode);
    if S = '' then FmtStr(S, SOleError, [ErrorCode]);
  end;
  inherited Create(S{, HelpContext});
  //inherited CreateHelp(S, HelpContext);
  FErrorCode := ErrorCode;
end;

{ Raise EOleSysError exception from an error code }

procedure OleError(ErrorCode: HResult);
begin
  raise EOleSysError.Create('', ErrorCode, 0);
end;

{ Raise EOleSysError exception if result code indicates an error }

procedure OleCheck(Result: HResult);
begin
  if not Succeeded(Result) then OleError(Result);
end;

{ Convert a programmatic ID to a class ID }

function ProgIDToClassID(const ProgID: string): TGUID;
var
  P: IntPtr;
begin
  P := Marshal.StringToCoTaskMemUni(ProgId);
  OleCheck(CLSIDFromProgID(P, Result));
end;

{ Convert a class ID to a programmatic ID }

function ClassIDToProgID(const ClassID: TGUID): string;
var
  P: IntPtr;
begin
  OleCheck(ProgIDFromCLSID(ClassID, P));
  Result := Marshal.PtrToStringUni(P);
  Marshal.FreeCoTaskMem(P);
end;

{ Create registry key }

procedure CreateRegKey(const Key, ValueName, Value: string; RootKey: DWord = HKEY_CLASSES_ROOT);
var
  Handle: HKey;
  Status: Integer;
  Disposition: DWORD;
begin
  Status := RegCreateKeyEx(RootKey, Key, 0, '',
    REG_OPTION_NON_VOLATILE, KEY_READ or KEY_WRITE, nil, Handle, Disposition);
  if Status = 0 then
  begin
    Status := RegSetValueEx(Handle, ValueName, 0, REG_SZ,
      BytesOf(Value), Length(Value) + 1);
    RegCloseKey(Handle);
  end;
  if Status <> 0 then
    raise EOleRegistrationError.Create(SCreateRegKeyError);
end;

{ Delete registry key }

procedure DeleteRegKey(const Key: string; RootKey: DWord = HKEY_CLASSES_ROOT);
begin
  RegDeleteKey(RootKey, Key);
end;

{ Get registry value }

function GetRegStringValue(const Key, ValueName: string; RootKey: DWord = HKEY_CLASSES_ROOT): string;
var
  Size: Integer;
  RegKey: HKEY;
  Buffer: StringBuilder;
begin
  Result := '';
  if RegOpenKey(RootKey, Key, RegKey) = ERROR_SUCCESS then
  try
    Size := 256;
    Buffer := StringBuilder.Create(Size);
    if RegQueryValueEx(RegKey, ValueName, nil, nil, Buffer, Size) = ERROR_SUCCESS then
      Result := Buffer.ToString
    else
      Result := '';
  finally
    RegCloseKey(RegKey);
  end;
end;

function CreateComObject(const ClassID: TGUID): TObject;
begin
  Result := Activator.CreateInstance(System.Type.GetTypeFromCLSID(ClassID));
end;

function CreateRemoteComObject(const MachineName: WideString;
  const ClassID: TGUID): TObject;
const
  LocalFlags = CLSCTX_LOCAL_SERVER or CLSCTX_REMOTE_SERVER or CLSCTX_INPROC_SERVER;
  RemoteFlags = CLSCTX_REMOTE_SERVER;
var
  MQI: TMultiQIArray;
  ServerInfo: TCoServerInfo;
  Flags, Size: DWORD;
  LocalMachine: StringBuilder;
  Ole32: HModule;
  Handle: GCHandle;
begin
  Ole32 := GetModuleHandle('ole32.dll');
  if GetProcAddress(Ole32, 'CoCreateInstanceEx') = nil then
    raise Exception.Create(SDCOMNotInstalled);

  ServerInfo.pwszName := MachineName;
  Handle := GCHandle.Alloc(TGUID.Create(IID_IUnknown), GCHandleType.Pinned);
  try
    SetLength(MQI, 1);
    MQI[0].IID := Handle.AddrOfPinnedObject;

    { If a MachineName is specified check to see if it the local machine.
      If it isn't, do not allow LocalServers to be used. }
    if Length(MachineName) > 0 then
    begin
      Size := MAX_COMPUTERNAME_LENGTH; // Win95 is hypersensitive to size
      LocalMachine := StringBuilder.Create(Size);
      if GetComputerName(LocalMachine, Size) and
         (AnsiCompareText(LocalMachine.ToString, MachineName) = 0) then
        Flags := LocalFlags
      else
        Flags := RemoteFlags;
    end
    else
      Flags := LocalFlags;

    { Use CoCreateInstanceEx because Activator.CreateInstance does not
      provide a way to prevent loading the server on the local machine
      (if it is found locally). }
    OleCheck(CoCreateInstanceEx(ClassID, nil, Flags, ServerInfo, 1, MQI));
    OleCheck(MQI[0].HR);
    Result := MQI[0].itf;
  finally
    if Handle.IsAllocated then Handle.Free;
  end;
end;

end.
