mconnect.pas

多数代码可以直接在Delphi6和Delphi7环境下运行。部分涉及.NET技术内容的代码

{*******************************************************}
{                                                       }
{       Borland Delphi Visual Component Library         }
{       Connection classes                              }
{                                                       }
{       Copyright (c) 1997,99 Inprise Corporation       }
{                                                       }
{*******************************************************}

unit MConnect;

interface

uses Variants, Windows, SysUtils, Classes, Midas, DB, DBClient, ActiveX,
  ComObj, Provider;

type

  { TCustomObjectBroker }

  TCustomObjectBroker = class(TComponent)
  public
    procedure SetConnectStatus(ComputerName: string; Success: Boolean); virtual; abstract;
    function GetComputerForGUID(GUID: TGUID): string; virtual; abstract;
    function GetComputerForProgID(const ProgID): string; virtual; abstract;
    function GetPortForComputer(const ComputerName: string): Integer; virtual; abstract;
  end;

  { TDispatchAppServer }

  TDispatchAppServer = class(TInterfacedObject, IAppServer, ISupportErrorInfo)
  private
    FAppServer: IAppServerDisp;
    { 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;
    { IAppServer }
    function AS_ApplyUpdates(const ProviderName: WideString; Delta: OleVariant; MaxErrors: Integer;
                          out ErrorCount: Integer; var OwnerData: OleVariant): OleVariant; safecall;
    function AS_GetRecords(const ProviderName: WideString; Count: Integer; out RecsOut: Integer;
                        Options: Integer; const CommandText: WideString; var Params, OwnerData: OleVariant): OleVariant; safecall;
    function AS_DataRequest(const ProviderName: WideString; Data: OleVariant): OleVariant; safecall;
    function AS_GetProviderNames: OleVariant; safecall;
    function AS_GetParams(const ProviderName: WideString; var OwnerData: OleVariant): OleVariant; safecall;
    function AS_RowRequest(const ProviderName: WideString; Row: OleVariant;
      RequestType: Integer; var OwnerData: OleVariant): OleVariant; safecall;
    procedure AS_Execute(const ProviderName: WideString; const CommandText: WideString; var Params, OwnerData: OleVariant); safecall;
    { ISupportErrorInfo }
    function InterfaceSupportsErrorInfo(const iid: TIID): HResult; stdcall;
  public
    constructor Create(const AppServer: IAppServerDisp);
    function SafeCallException(ExceptObject: TObject;
      ExceptAddr: Pointer): HResult; override;
  end;

  { TDispatchConnection }

  TDispatchConnection = class(TCustomRemoteServer)
  private
    FServerGUID: TGUID;
    FServerName: string;
    FObjectBroker: TCustomObjectBroker;
    function GetServerGUID: string;
    procedure SetServerGUID(const Value: string);
    procedure SetServerName(const Value: string);
    procedure SetObjectBroker(Value: TCustomObjectBroker);
  protected
    function GetServerList: OleVariant; override;
    procedure DoDisconnect; override;
    function GetConnected: Boolean; override;
    procedure SetConnected(Value: Boolean); override;
    function GetServerCLSID: TGUID;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    property ObjectBroker: TCustomObjectBroker read FObjectBroker write SetObjectBroker;
  public
    constructor Create(AOwner: TComponent); override;
    function GetServer: IAppServer; override;
  published
    property Connected;
    property LoginPrompt default False;
    property ServerGUID: string read GetServerGUID write SetServerGUID;
    property ServerName: string read FServerName write SetServerName;
    property AfterConnect;
    property AfterDisconnect;
    property BeforeConnect;
    property BeforeDisconnect;
    property OnGetUsername;
    property OnLogin;
  end;

  { TCOMConnection }

  TCOMConnection = class(TDispatchConnection)
  protected
    procedure SetConnected(Value: Boolean); override;
    procedure DoConnect; override;
  end;

  { TDCOMConnection }

  TDCOMConnection = class(TCOMConnection)
  private
    FComputerName: string;
    procedure SetComputerName(const Value: string);
    function IsComputerNameStored: Boolean;
  protected
    procedure DoConnect; override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property ComputerName: string read FComputerName write SetComputerName stored IsComputerNameStored;
    property ObjectBroker;
  end;

  { TOLEnterpriseConnection }

  TOLEnterpriseConnection = class(TCOMConnection)
  private
    FComputerName: string;
    FBrokerName: string;
    procedure SetComputerName(const Value: string);
    procedure SetBrokerName(const Value: string);
  protected
    procedure DoConnect; override;
  published
    property ComputerName: string read FComputerName write SetComputerName;
    property BrokerName: string read FBrokerName write SetBrokerName;
  end;

{ TSharedConnection }

  TSharedConnection = class(TCustomRemoteServer)
  private
    FParentConnection: TDispatchConnection;
    FChildName: String;
    procedure SetParentConnection(const Value: TDispatchConnection);
  protected
    procedure ConnectEvent(Sender: TObject; Connecting: Boolean);
    procedure DoConnect; override;
    procedure DoDisconnect; override;
    function GetConnected: Boolean; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    destructor Destroy; override;
    function GetServer: IAppServer; override;
  published
    constructor Create(AOwner: TComponent); override;
    property ParentConnection: TDispatchConnection read FParentConnection write SetParentConnection;
    property ChildName: String read FChildName write FChildName;
    property AfterConnect;
    property AfterDisconnect;
    property BeforeConnect;
    property BeforeDisconnect;
  end;

  procedure GetMIDASAppServerList(List: TStringList; const RegCheck: string);

implementation

uses Registry, MidConst;

procedure GetMIDASAppServerList(List: TStringList; const RegCheck: string);
var
  EnumGUID: IEnumGUID;
  Fetched: Cardinal;
  Guid: TGUID;
  Rslt: HResult;
  CatInfo: ICatInformation;
  I, BufSize: Integer;
  ClassIDKey: HKey;
  S: string;
  Buffer: array[0..255] of Char;
begin
  List.Clear;
  Rslt := CoCreateInstance(CLSID_StdComponentCategoryMgr, nil,
    CLSCTX_INPROC_SERVER, ICatInformation, CatInfo);
  if Succeeded(Rslt) then
  begin
    OleCheck(CatInfo.EnumClassesOfCategories(1, @CATID_MIDASAppServer, 0, nil, EnumGUID));
    while EnumGUID.Next(1, Guid, Fetched) = S_OK do
    begin
      if RegCheck <> '' then
      begin
        S := SClsid + GuidToString(Guid) + '\';
        if GetRegStringValue(S, RegCheck) <> SFlagOn then continue;
      end;
      List.Add(ClassIDToProgID(Guid));
    end;
  end else
  begin
    if RegOpenKey(HKEY_CLASSES_ROOT, 'CLSID', ClassIDKey) <> 0 then
      try
        I := 0;
        while RegEnumKey(ClassIDKey, I, Buffer, SizeOf(Buffer)) = 0 do
        begin
          S := Format(SCatImplKey, [Buffer, GUIDToString(CATID_MIDASAppServer)]);
          if RegQueryValue(ClassIDKey, PChar(S), nil, BufSize) = 0 then
            if RegCheck <> '' then
            begin
              BufSize := 256;
              SetLength(S, BufSize);
              if RegQueryValueEx(ClassIDKey, PChar(RegCheck), nil, nil,
                    PByte(PChar(S)), @BufSize) = ERROR_SUCCESS then
                SetLength(S, BufSize - 1) else
                S := '';
              if GetRegStringValue(S, RegCheck) <> SFlagOn then continue;
            end;
          List.Add(ClassIDToProgID(StringToGUID(Buffer)));
          Inc(I);
        end;
      finally
        RegCloseKey(ClassIDKey);
      end;
  end;
end;

{ TDispatchAppServer }

constructor TDispatchAppServer.Create(const AppServer: IAppServerDisp);
begin
  inherited Create;
  FAppServer := AppServer;
end;

{ TDispatchAppServer.IDispatch }

function TDispatchAppServer.GetTypeInfoCount(out Count: Integer): HResult;
begin
  Result := IDispatch(FAppServer).GetTypeInfoCount(Count);
end;

function TDispatchAppServer.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
begin
  Result := IDispatch(FAppServer).GetTypeInfo(Index, LocaleID, TypeInfo);
end;

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

function TDispatchAppServer.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
begin
  Result := IDispatch(FAppServer).Invoke(DispID, IID, LocaleID, Flags, Params,
    VarResult, ExcepInfo, ArgErr);
end;

{ TDispatchAppServer.IAppServer }

function TDispatchAppServer.AS_ApplyUpdates(const ProviderName: WideString;
  Delta: OleVariant; MaxErrors: Integer; out ErrorCount: Integer;
  var OwnerData: OleVariant): OleVariant; safecall;
begin
  Result := FAppServer.AS_ApplyUpdates(ProviderName, Delta, MaxErrors, ErrorCount,
    OwnerData);
end;

function TDispatchAppServer.AS_GetRecords(const ProviderName: WideString;
  Count: Integer; out RecsOut: Integer; Options: Integer; const CommandText: WideString; var Params,
  OwnerData: OleVariant): OleVariant; safecall;
begin
  Result := FAppServer.AS_GetRecords(ProviderName, Count, RecsOut, Options, CommandText, Params,
    OwnerData);
end;

function TDispatchAppServer.AS_DataRequest(const ProviderName: WideString;
  Data: OleVariant): OleVariant; safecall;
begin
  Result := FAppServer.AS_DataRequest(ProviderName, Data);
end;

function TDispatchAppServer.AS_GetProviderNames: OleVariant;
begin
  Result := FAppServer.AS_GetProviderNames;
end;

function TDispatchAppServer.AS_GetParams(const ProviderName: WideString;
  var OwnerData: OleVariant): OleVariant;
begin
  Result := FAppServer.AS_GetParams(ProviderName, OwnerData);
end;

function TDispatchAppServer.AS_RowRequest(const ProviderName: WideString;
  Row: OleVariant; RequestType: Integer; var OwnerData: OleVariant): OleVariant;
begin
  Result := FAppServer.AS_RowRequest(ProviderName, Row, RequestType, OwnerData);
end;

procedure TDispatchAppServer.AS_Execute(const ProviderName: WideString;
  const CommandText: WideString; var Params, OwnerData: OleVariant);
begin
  FAppServer.AS_Execute(ProviderName, CommandText, Params, OwnerData);
end;

{ TDispatchAppServer.ISupportErrorInfo }

function TDispatchAppServer.InterfaceSupportsErrorInfo(const iid: TIID): HResult;
begin
  if IsEqualGUID(IAppServer, iid) then
    Result := S_OK else
    Result := S_FALSE;
end;

function TDispatchAppServer.SafeCallException(ExceptObject: TObject;
  ExceptAddr: Pointer): HResult;
begin
  Result := HandleSafeCallException(ExceptObject, ExceptAddr, IAppServer, '', '');
end;

{ TDispatchConnection }

constructor TDispatchConnection.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  RCS;
  LoginPrompt := False;
end;

function TDispatchConnection.GetServerList: OleVariant;
var
  List: TStringList;
  i: Integer;
begin
  Result := NULL;
  List := TStringList.Create;
  try
    GetMIDASAppServerList(List, '');
    if List.Count > 0 then
    begin
      Result := VarArrayCreate([0, List.Count - 1], varOleStr);
      for i := 0 to List.Count - 1 do
        Result[i] := List[i];
    end;
  finally
    List.Free;
  end;
end;

procedure TDispatchConnection.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FObjectBroker) then
    FObjectBroker := nil;
end;

procedure TDispatchConnection.SetObjectBroker(Value: TCustomObjectBroker);
begin
  if Value = FObjectBroker then Exit;
  if Assigned(Value) then
    Value.FreeNotification(Self);
  FObjectBroker := Value;
end;

function TDispatchConnection.GetServerGUID: string;
begin
  if (FServerGUID.D1 <> 0) or (FServerGUID.D2 <> 0) or (FServerGUID.D3 <> 0) then
    Result := GUIDToString(FServerGUID) else
    Result := '';
end;