oleauto.pas

这是不可多得的源代码

{*******************************************************}
{                                                       }
{       Borland Delphi Visual Component Library         }
{                                                       }
{  Copyright (c) 1995-2001 Borland Software Corporation }
{                                                       }
{*******************************************************}

unit OleAuto deprecated;

{$DENYPACKAGEUNIT}

{ OleAuto cannot be used in a package DLL.  To implement
  an OLE automation server in a package, use the new
  OLE automation support in comobj and comserv.
}

{$R-,T-,H+,X+}

// For CBuilder v1.0 backward compatiblity, OLEAUTO.HPP must include comobj.hpp
(*$HPPEMIT '#include <comobj.hpp>'*)

interface

uses Windows, Ole2, OleCtl, SysUtils;

const

{ Maximum number of dispatch arguments }

  MaxDispArgs = 32;

type

{ Forward declarations }

  TAutoObject = class;

{ Dispatch interface for TAutoObject }

  {$EXTERNALSYM TAutoDispatch }
  { NOTE: TAutoDispatch is not really an External Symbol. However, it derives from IDispatch
    which is. However, in the C++ world, a DELPHICLASS cannot derive from a non-Delphi
    Class. }
  TAutoDispatch = class(IDispatch)
  private
    FAutoObject: TAutoObject;
  public
    constructor Create(AutoObject: TAutoObject);
    function QueryInterface(const iid: TIID; var obj): HResult; override;
    function AddRef: Longint; override;
    function Release: Longint; override;
    function GetTypeInfoCount(var ctinfo: Integer): HResult; override;
    function GetTypeInfo(itinfo: Integer; lcid: TLCID;
      var tinfo: ITypeInfo): HResult; override;
    function GetIDsOfNames(const iid: TIID; rgszNames: POleStrList;
      cNames: Integer; lcid: TLCID; rgdispid: PDispIDList): HResult; override;
    function Invoke(dispIDMember: TDispID; const iid: TIID; lcid: TLCID;
      flags: Word; var dispParams: TDispParams; varResult: PVariant;
      excepInfo: PExcepInfo; argErr: PInteger): HResult; override;
    function GetAutoObject: TAutoObject; virtual; stdcall;
    property AutoObject: TAutoObject read FAutoObject;
  end;

{ TAutoObject - Automation object base class. An automation class is
  implemented by deriving a new class from TAutoObject, and declaring methods
  and properties in an "automated" section in the new class. To expose an
  automation class to external OLE Automation Controllers, the unit that
  implements the automation class must call Automation.RegisterClass in its
  initialization section, passing in a TAutoClassInfo structure. Once a
  class has been registered in this way, the global Automation object
  automatically manages all aspects of interfacing with the OLE Automation
  APIs.

  When an external OLE Automation Controller requests an instance of an
  automation class, the Create constructor is called to create the object,
  and when all external references to the object disappear, the Destroy
  destructor is called to destroy the object. As is the case with all OLE
  objects, automation objects are reference counted. }

  {$EXTERNALSYM TAutoObject}

  TAutoObject = class(TObject)
  private
    FRefCount: Integer;
    FAutoDispatch: TAutoDispatch;
    function GetIDsOfNames(Names: POleStrList; Count: Integer;
      DispIDs: PDispIDList): HResult;
    function GetOleObject: Variant;
    function Invoke(DispID: TDispID; Flags: Integer; var Params: TDispParams;
      VarResult: PVariant; ExcepInfo: PExcepInfo; ArgErr: PInteger): HResult;
    procedure InvokeMethod(AutoEntry, Args, Result: Pointer);
    function QueryInterface(const iid: TIID; var obj): HResult;
  protected
    function CreateAutoDispatch: TAutoDispatch; virtual;
    procedure GetExceptionInfo(ExceptObject: TObject;
      var ExcepInfo: TExcepInfo); virtual;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    function AddRef: Integer;
    function Release: Integer;
    property AutoDispatch: TAutoDispatch read FAutoDispatch;
    property OleObject: Variant read GetOleObject;
    property RefCount: Integer read FRefCount;
  end;

{ Automation object class reference }

  TAutoClass = class of TAutoObject;

{ Instancing mode for local server automation classes }

  TAutoClassInstancing = (acInternal, acSingleInstance, acMultiInstance);

{ Automation class registration info }

  TAutoClassInfo = record
    AutoClass: TAutoClass;
    ProgID: string;
    ClassID: string;
    Description: string;
    Instancing: TAutoClassInstancing;
  end;

{ Class registry entry }

  TRegistryClass = class
  private
    FNext: TRegistryClass;
    FAutoClass: TAutoClass;
    FProgID: string;
    FClassID: TCLSID;
    FDescription: string;
    FInstancing: TAutoClassInstancing;
    FRegister: Longint;
  public
    constructor Create(const AutoClassInfo: TAutoClassInfo);
    destructor Destroy; override;
    procedure UpdateRegistry(Register: Boolean);
  end;

{ Application start mode }

  TStartMode = (smStandalone, smAutomation, smRegServer, smUnregServer);

{ Automation manager event types }

  TLastReleaseEvent = procedure(var Shutdown: Boolean) of object;

{ Automation manager object }

  TAutomation = class
  private
    FRegistryList: TRegistryClass;
    FAutoObjectCount: Integer;
    FClassFactoryCount: Integer;
    FIsInprocServer: Boolean;
    FStartMode: TStartMode;
    FOnLastRelease: TLastReleaseEvent;
    procedure CountAutoObject(Created: Boolean);
    procedure Initialize;
    procedure LastReleased;
  public
    constructor Create;
    destructor Destroy; override;
    procedure RegisterClass(const AutoClassInfo: TAutoClassInfo);
    procedure UpdateRegistry(Register: Boolean);
    property AutoObjectCount: Integer read FAutoObjectCount;
    property IsInprocServer: Boolean read FIsInprocServer write FIsInprocServer;
    property StartMode: TStartMode read FStartMode;
    property OnLastRelease: TLastReleaseEvent read FOnLastRelease write FOnLastRelease;
  end;

{ OLE exception classes }

  EOleError = class(Exception);

  EOleSysError = class(EOleError)
  private
    FErrorCode: Integer;
  public
    constructor Create(ErrorCode: Integer);
    property ErrorCode: Integer read FErrorCode;
  end;

  EOleException = class(EOleError)
  private
    FErrorCode: Integer;
    FSource: string;
    FHelpFile: string;
  public
    constructor Create(const ExcepInfo: TExcepInfo);
    property ErrorCode: Integer read FErrorCode;
    property HelpFile: string read FHelpFile;
    property Source: string read FSource;
  end;

var
  Automation: TAutomation;

{ CreateOleObject creates an OLE automation object of the given class. }

function CreateOleObject(const ClassName: string): Variant;

{ GetActiveOleObject returns the active object for the given class. }

function GetActiveOleObject(const ClassName: string): Variant;

{ The DllXXXX routines implement the required entry points of an in-process
  automation server DLL. These routines must be exported by the DLL using
  an "exports" clause in the library's main module. }

function DllGetClassObject(const CLSID: TCLSID; const IID: TIID;
  var Obj): HResult; stdcall;
function DllCanUnloadNow: HResult; stdcall;
function DllRegisterServer: HResult; stdcall;
function DllUnregisterServer: HResult; stdcall;

{ VarFromInterface returns a variant that contains the a reference to the
  IDispatch interface of the given IUnknown interface. If the Unknown
  parameter is NIL, the resulting variant is set to Unassigned. }

function VarFromInterface(Unknown: IUnknown): Variant;

{ VarToInterface returns the IDispatch interface reference stored in the
  given variant. An exception is raised if the variant does not contain
  an IDispatch interface. VarToInterface does not affect the reference
  count of the returned IDispatch. The caller of VarToInterface must
  manually call AddRef and Release on the returned interface. }

function VarToInterface(const V: Variant): IDispatch;

{ VarToAutoObject returns the TAutoObject instance corresponding to the
  IDispatch interface reference stored in the given variant. An exception
  is raised if the variant does not contain an IDispatch interface, or if
  the IDispatch interface is not that of a TAutoObject instance. }

{$EXTERNALSYM VarToAutoObject}
function VarToAutoObject(const V: Variant): TAutoObject;

procedure DispInvoke(Dispatch: IDispatch; CallDesc: PCallDesc;
  DispIDs: PDispIDList; Params: Pointer; Result: PVariant);
procedure DispInvokeError(Status: HResult; const ExcepInfo: TExcepInfo);

procedure OleError(ErrorCode: HResult);
procedure OleCheck(Result: HResult);

function StringToClassID(const S: string): TCLSID;
function ClassIDToString(const ClassID: TCLSID): string;

function ProgIDToClassID(const ProgID: string): TCLSID;
function ClassIDToProgID(const ClassID: TCLSID): string;

implementation

uses OleConst, ComObj;

const

{ Special variant type codes }

  varStrArg = $0048;

{ Parameter type masks }

  atVarMask  = $3F;
  atTypeMask = $7F;
  atByRef    = $80;

{ Automation entry flags }

  afMethod  = $00000001;
  afPropGet = $00000002;
  afPropSet = $00000004;
  afVirtual = $00000008;

type

{ Automation entry parameter list }

  PParamList = ^TParamList;
  TParamList = record
    ResType: Byte;
    ParamCount: Byte;
    ParamTypes: array[0..255] of Byte;
  end;

{ Automation table entry }

  PAutoEntry = ^TAutoEntry;
  TAutoEntry = record
    DispID: Integer;
    Name: PShortString;
    Flags: Integer;
    Params: PParamList;
    Address: Pointer;
  end;

{ Automation table layout }

  PAutoTable = ^TAutoTable;
  TAutoTable = record
    EntryCount: Integer;
    Entries: array[0..4095] of TAutoEntry;
  end;

{ Class factory }

  TClassFactory = class(IClassFactory)
  private
    FRefCount: Integer;
    FAutoClass: TAutoClass;
  public
    constructor Create(AutoClass: TAutoClass);
    destructor Destroy; override;
    function QueryInterface(const iid: TIID; var obj): HResult; override;
    function AddRef: Longint; override;
    function Release: Longint; override;
    function CreateInstance(unkOuter: IUnknown; const iid: TIID;
      var obj): HResult; override;
    function LockServer(fLock: BOOL): HResult; override;
  end;

{ IAutoDispatch interface ID }

const
  IID_IAutoDispatch: TGUID = ( {F5B2B8E0-1627-11CF-BD2F-0020AF0E5B81}
    D1:$F5B2B8E0;D2:$1627;D3:$11CF;D4:($BD,$2F,$00,$20,$AF,$0E,$5B,$81));

{ Raise EOleSysError exception from an error code }

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

{ Raise EOleSysError exception if result code indicates an error }

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

{ Convert a string to a class ID }

function StringToClassID(const S: string): TCLSID;
var
  Buffer: array[0..127] of WideChar;
begin
  OleCheck(CLSIDFromString(StringToWideChar(S, Buffer,
    SizeOf(Buffer) div 2), Result));
end;

{ Convert a class ID to a string }

function ClassIDToString(const ClassID: TCLSID): string;
var
  P: PWideChar;
begin
  OleCheck(StringFromCLSID(ClassID, P));
  Result := WideCharToString(P);
  CoTaskMemFree(P);
end;

{ Convert a programmatic ID to a class ID }

function ProgIDToClassID(const ProgID: string): TCLSID;
var
  Buffer: array[0..127] of WideChar;
begin
  OleCheck(CLSIDFromProgID(StringToWideChar(ProgID, Buffer,
    SizeOf(Buffer) div 2), Result));
end;

{ Convert a class ID to a programmatic ID }

function ClassIDToProgID(const ClassID: TCLSID): string;
var
  P: PWideChar;
begin
  OleCheck(ProgIDFromCLSID(ClassID, P));
  Result := WideCharToString(P);
  CoTaskMemFree(P);
end;

{ Create registry key }

procedure CreateRegKey(const Key, Value: string);
begin
  RegSetValue(HKEY_CLASSES_ROOT, PChar(Key), REG_SZ, PChar(Value),
    Length(Value));
end;

{ Delete registry key }

procedure DeleteRegKey(const Key: string);
begin
  RegDeleteKey(HKEY_CLASSES_ROOT, PChar(Key));
end;

{ Get server key name }

function GetServerKey: string;
begin
  if Automation.IsInprocServer then
    Result := 'InprocServer32' else
    Result := 'LocalServer32';
end;

{ Find command-line switch }

function FindCmdLineSwitch(const Switch: string): Boolean;
var
  I: Integer;
  S: string;
begin
  for I := 1 to ParamCount do
  begin
    S := ParamStr(I);
    if (S[1] in ['-', '/']) and
      (CompareText(Copy(S, 2, Maxint), Switch) = 0) then
    begin
      Result := True;
      Exit;
    end;
  end;
  Result := False;
end;

{ Convert wide character string to ShortString }

procedure WideCharToShortString(P: PWideChar; var S: ShortString);
var
  I: Integer;
  W: WideChar;
begin
  I := 0;
  repeat
    W := P[I];
    if W = #0 then Break;
    if W >= #256 then W := #0;
    Inc(I);
    S[I] := Char(W);
  until I = 255;
  S[0] := Char(I);
end;

{ Compare two symbols }

function SameSymbol(const Ident1, Ident2: ShortString): Boolean;
asm
        PUSH    EBX
        XOR     EBX,EBX
        XOR     ECX,ECX
        MOV     CL,[EAX]
        CMP     CL,[EDX]
        JNE     @@2
@@1:    MOV     BH,[EAX+ECX]
        XOR     BH,[EDX+ECX]
        TEST    BH,0DFH
        JNE     @@2
        DEC     ECX
        JNE     @@1
        INC     EBX
@@2:    XOR     EAX,EAX
        MOV     AL,BL
        POP     EBX
end;

{ Return automation table of the given class }

function GetAutoTable(ClassRef: TClass): PAutoTable;
asm
        MOV     EAX,[EAX].vmtAutoTable
end;

{ Return dispatch ID of the given name in the given class }

function GetDispIDOfName(ClassRef: TClass; const Name: ShortString): Integer;
var
  AutoTable: PAutoTable;
  NameStart: Word;
  I: Integer;
  P: PAutoEntry;
begin
  NameStart := Word((@Name)^);
  repeat
    AutoTable := GetAutoTable(ClassRef);
    if AutoTable <> nil then
    begin
      I := AutoTable^.EntryCount;
      P := @AutoTable^.Entries;
      repeat
        if ((NameStart xor Word(Pointer(P^.Name)^)) and $DFFF = 0) and
          SameSymbol(Name, P^.Name^) then
        begin
          Result := P^.DispID;
          Exit;
        end;
        Inc(Integer(P), SizeOf(TAutoEntry));
        Dec(I);
      until I = 0;
    end;
    ClassRef := ClassRef.ClassParent;
  until ClassRef = nil;
  Result := -1;
end;

{ Return automation table entry for the given dispatch ID and dispatch
  flags in the given class }

function GetAutoEntry(ClassRef: TClass; DispID, Flags: Integer): PAutoEntry;
var
  AutoTable: PAutoTable;
  I: Integer;
begin
  repeat