oleserver.pas

这是不可多得的源代码

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

unit OleServer;

{$R-}
{$WARN SYMBOL_PLATFORM OFF}

interface

uses Windows, Messages, ActiveX, SysUtils, Classes, ComObj;

type
  TVariantArray = Array of OleVariant;
  TOleServer    = class;
  TConnectKind  = (ckRunningOrNew,          // Attach to a running or create a new instance of the server
                   ckNewInstance,           // Create a new instance of the server
                   ckRunningInstance,       // Attach to a running instance of the server
                   ckRemote,                // Bind to a remote instance of the server
                   ckAttachToInterface);    // Don't bind to server, user will provide interface via 'CpnnectTo'

  TServerEventDispatch = class(TObject, IUnknown, IDispatch)
  private
    FServer: TOleServer;
    InternalRefCount : Integer;
  protected
    { IUnknown }
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    { IDispatch }
    function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
    property Server: TOleServer read FServer;
    function ServerDisconnect :Boolean;
  public
    constructor Create(Server: TOleServer);
  end;

  PServerData = ^TServerData;
  TServerData = record
    ClassID: TGUID;                   // CLSID of CoClass
    IntfIID: TGUID;                   // IID of default interface
    EventIID: TGUID;                  // IID of default source interface
    LicenseKey: Pointer;              // Pointer to license string (not implemented)
    Version: Integer;                 // Version of this structure
    InstanceCount: Integer;           // Instance of the Server running
  end;

  TOleServer = class(TComponent, IUnknown)
  private
    FServerData:        PServerData;
    FRefCount:          Longint;
    FEventDispatch:     TServerEventDispatch;
    FEventsConnection:  Longint;
    FAutoConnect:       Boolean;
    FRemoteMachineName: string;
    FConnectKind:       TConnectKind;

  protected
      { IUnknown }
    function QueryInterface(const IID: TGUID; out Obj): HResult; override;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;

    procedure Loaded; override;
    procedure InitServerData; virtual; abstract;

    function  GetServer: IUnknown; virtual;

    procedure ConnectEvents(const Obj: IUnknown);
    procedure DisconnectEvents(const Obj: Iunknown);
    procedure InvokeEvent(DispID: TDispID; var Params: TVariantArray); virtual;

    function  GetConnectKind: TConnectKind;
    procedure SetConnectKind(ck: TConnectKind);

    function  GetAutoConnect: Boolean;
    procedure SetAutoConnect(flag: Boolean);

    property  ServerData: PServerData read FServerData write FServerData;
    property  EventDispatch: TServerEventDispatch read FEventDispatch write FEventDispatch;

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    // NOTE: If derived class is generated by TLIBIMP or ImportTypeLibraryCodeGenerator,
    //       the derived class will also expose a 'ConnectTo(interface)' function.
    //       You must invoke that method if you're using 'ckAttachToInterface' connection
    //       kind.
    procedure Connect; virtual; abstract;
    procedure Disconnect; virtual; abstract;

  published
    property AutoConnect: Boolean read GetAutoConnect write SetAutoConnect;
    property ConnectKind: TConnectKind read GetConnectKind write SetConnectKind;
    property RemoteMachineName: string read FRemoteMachineName write FRemoteMachineName;
  end;


implementation

uses OleConst, Controls;

{ TServerEventDispatch }
constructor TServerEventDispatch.Create(Server: TOleServer);
begin
  FServer := Server;
  InternalRefCount := 1;
end;

{ TServerEventDispatch.IUnknown }
function TServerEventDispatch.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
  begin
    Result := S_OK;
    Exit;
  end;
  if IsEqualIID(IID, FServer.FServerData^.EventIID) then
  begin
    GetInterface(IDispatch, Obj);
    Result := S_OK;
    Exit;
  end;
  Result := E_NOINTERFACE;
end;

function TServerEventDispatch._AddRef: Integer;
begin
  if FServer <> nil then FServer._AddRef;
  InternalRefCount := InternalRefCount + 1;
  Result := InternalRefCount;
end;

function TServerEventDispatch._Release: Integer;
begin
  if FServer <> nil then FServer._Release;
  InternalRefCount := InternalRefCount -1;
  Result := InternalRefCount;
end;

{ TServerEventDispatch.IDispatch }
function TServerEventDispatch.GetTypeInfoCount(out Count: Integer): HResult;
begin
  Count := 0;
  Result:= S_OK;
end;

function TServerEventDispatch.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
begin
  Pointer(TypeInfo) := nil;
  Result := E_NOTIMPL;
end;

function TServerEventDispatch.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
  Result := E_NOTIMPL;
end;

function TServerEventDispatch.Invoke(DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; var Params;
  VarResult, ExcepInfo, ArgErr: Pointer): HResult;
var
  i: integer;
  vVarArray : TVariantArray;

  vPVarArgIn: PVariantArg;
  vPDispParams: PDispParams;
  vFistArrItem, vLastArrItem: integer;
begin
  vPDispParams := PDispParams(@Params);     // DispParams
  SetLength(vVarArray, vPDispParams.cArgs); // set our array to appropriate length

  // array boundaries
  vFistArrItem := Low(vVarArray); vLastArrItem := High(vVarArray);

  if vPDispParams.cNamedArgs > 0 then
    // Copy over data from Params in NamedArgs order
    for i := vFistArrItem to vLastArrItem do
    begin
      vPVarArgIn := @vPDispParams.rgvarg[i];
      vVarArray[vPDispParams.rgdispidNamedArgs[i]] := POleVariant(vPVarArgIn)^;
    end
  else
    // Copy over data from Params in reverse order
    for i := vFistArrItem to vLastArrItem do
    begin
      vPVarArgIn := @vPDispParams.rgvarg[i];
      vVarArray[vLastArrItem - i] := POleVariant(vPVarArgIn)^;
    end;

  // Invoke Server proxy class
  if FServer <> nil then
    FServer.InvokeEvent(DispID, vVarArray);

  if vPDispParams.cNamedArgs > 0 then
    // Copy data back to DispParams if Item passed by reference (NamedArgs order)
    for i := vFistArrItem to vLastArrItem do
    begin
      vPVarArgIn := @vPDispParams.rgvarg[i];
      if (vPVarArgIn.vt and varByRef) <> varByRef then
        Continue;
      POleVariant(vPVarArgIn)^ := vVarArray[vPDispParams.rgdispidNamedArgs[i]];
    end
  else
    // Copy data back to DispParams if Item passed by reference (reverse order)
    for i := vFistArrItem to vLastArrItem do
    begin
      vPVarArgIn := @vPDispParams.rgvarg[i];
      if (vPVarArgIn.vt and varByRef) <> varByRef then
        Continue;
      POleVariant(vPVarArgIn)^ := vVarArray[vLastArrItem - i];
    end;

  // Clean array
  SetLength(vVarArray, 0);

  // Pascal Events return 'void' - so assume success!
  Result := S_OK;
end;

function TServerEventDispatch.ServerDisconnect : Boolean;
begin
  FServer := nil;
  if FServer <> nil then
    Result := false
  else Result := true;
end;

{TOleServer}
constructor TOleServer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  // Allow derived class to initialize ServerData structure pointer
  InitServerData;
  // Make sure derived class set ServerData pointer to some valid structure
  Assert(FServerData <> nil);
  // Increment instance count (not used currently)
  Inc(FServerData^.InstanceCount);
  // Create Event Dispatch Handler
  FEventDispatch := TServerEventDispatch.Create(Self);
end;

destructor TOleServer.Destroy;
begin
  // Disconnect from the Server (NOTE: Disconnect must handle case when we're no longer connected)
  Disconnect;
  // Free Events dispatcher
  FEventDispatch.ServerDisconnect;
  if (FEventDispatch._Release = 0) then FEventDispatch.Free;
  // Decrement refcount
  Dec(FServerData^.InstanceCount);
  inherited Destroy;
end;

procedure TOleServer.Loaded;
begin
  inherited Loaded;

  // Load Server if user requested 'AutoConnect' and we're not in Design mode
  if not (csDesigning in ComponentState) then
    if AutoConnect then
        Connect;
end;

procedure TOleServer.InvokeEvent(DispID: TDispID; var Params: TVariantArray);
begin
  // To be overriden in derived classes to do dispatching
end;

function TOleServer.GetServer: IUnknown;
var
  HR: HResult;
  ErrorStr: string;
begin
  case ConnectKind of
    ckNewInstance:
      Result := CreateComObject(FServerData^.ClassId);

    ckRunningInstance:
    begin
      HR := GetActiveObject(FServerData^.ClassId, nil, Result);
      if not Succeeded(HR) then
      begin
        ErrorStr := Format(sNoRunningObject, [ClassIDToProgID(FServerData^.ClassId),
                                              GuidToString(FServerData^.ClassId)]);
        raise EOleSysError.Create(ErrorStr, HR, 0);
      end;
    end;

    ckRunningOrNew:
      if not Succeeded(GetActiveObject(FServerData^.ClassId, nil, Result)) then
        Result := CreateComObject(FServerData^.ClassId);

    ckRemote:
      {Highly inefficient: requires at least two round trips - GetClassObject + QI}
      Result := CreateRemoteComObject(RemoteMachineName, FServerData^.ClassID);
  end;
end;

procedure TOleServer.ConnectEvents(const Obj: IUnknown);
begin
  ComObj.InterfaceConnect(Obj, FServerData^.EventIID, FEventDispatch, FEventsConnection);
end;

procedure TOleServer.DisconnectEvents(const Obj: Iunknown);
begin
  ComObj.InterfaceDisconnect(Obj, FServerData^.EventIID, FEventsConnection);
end;

function  TOleServer.GetConnectKind: TConnectKind;
begin
  // Should the setting of a RemoteMachine name override the Connection Kind ??
  if RemoteMachineName <> '' then
    Result := ckRemote
  else
    Result := FConnectKind;
end;

procedure TOleServer.SetConnectKind(cK: TConnectKind);
begin
  // Should we validate that we have a RemoteMachineName for ckRemote ??
  FConnectKind := cK;
end;

function  TOleServer.GetAutoConnect: Boolean;
begin
  // If user wants to provide the interface to connect to, then we won't
  // 'automatically' connect to a server.
  if ConnectKind = ckAttachToInterface then
    Result := False
  else
    Result := FAutoConnect;
end;

procedure TOleServer.SetAutoConnect(flag: Boolean);
begin
  FAutoConnect := flag;
end;

{ TOleServer.IUnknown }
function TOleServer.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
    Result := S_OK
  else
    Result := E_NOINTERFACE;
end;

function TOleServer._AddRef: Integer;
begin
  Inc(FRefCount);
  Result := FRefCount;
end;

function TOleServer._Release: Integer;
begin
  Dec(FRefCount);
  Result := FRefCount;
end;

initialization
  GroupDescendentsWith(TOleServer, Controls.TControl);
end.