home *** CD-ROM | disk | FTP | other *** search
/ Delphi Anthology / aDELPHI.iso / Runimage / Delphi50 / Source / Vcl / mconnect.pas < prev    next >
Pascal/Delphi Source File  |  1999-08-11  |  22KB  |  669 lines
  1.  
  2.  
  3. {*******************************************************}
  4. {                                                       }
  5. {       Borland Delphi Visual Component Library         }
  6. {       Connection classes                              }
  7. {                                                       }
  8. {       Copyright (c) 1997,99 Inprise Corporation       }
  9. {                                                       }
  10. {*******************************************************}
  11.  
  12. unit MConnect;
  13.  
  14. interface
  15.  
  16. uses
  17.   Messages, Windows, SysUtils, Classes, Midas, DBClient, ActiveX, ComObj;
  18.  
  19. type
  20.  
  21.   { TCustomObjectBroker }
  22.  
  23.   TCustomObjectBroker = class(TComponent)
  24.   public
  25.     procedure SetConnectStatus(ComputerName: string; Success: Boolean); virtual; abstract;
  26.     function GetComputerForGUID(GUID: TGUID): string; virtual; abstract;
  27.     function GetComputerForProgID(const ProgID): string; virtual; abstract;
  28.     function GetPortForComputer(const ComputerName: string): Integer; virtual; abstract;
  29.   end;
  30.  
  31.   { TDispatchAppServer }
  32.  
  33.   TDispatchAppServer = class(TInterfacedObject, IAppServer, ISupportErrorInfo)
  34.   private
  35.     FAppServer: IAppServerDisp;
  36.     { IDispatch }
  37.     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
  38.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
  39.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  40.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
  41.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  42.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  43.     { IAppServer }
  44.     function AS_ApplyUpdates(const ProviderName: WideString; Delta: OleVariant; MaxErrors: Integer;
  45.                           out ErrorCount: Integer; var OwnerData: OleVariant): OleVariant; safecall;
  46.     function AS_GetRecords(const ProviderName: WideString; Count: Integer; out RecsOut: Integer;
  47.                         Options: Integer; const CommandText: WideString; var Params, OwnerData: OleVariant): OleVariant; safecall;
  48.     function AS_DataRequest(const ProviderName: WideString; Data: OleVariant): OleVariant; safecall;
  49.     function AS_GetProviderNames: OleVariant; safecall;
  50.     function AS_GetParams(const ProviderName: WideString; var OwnerData: OleVariant): OleVariant; safecall;
  51.     function AS_RowRequest(const ProviderName: WideString; Row: OleVariant;
  52.       RequestType: Integer; var OwnerData: OleVariant): OleVariant; safecall;
  53.     procedure AS_Execute(const ProviderName: WideString; const CommandText: WideString; var Params, OwnerData: OleVariant); safecall;
  54.     { ISupportErrorInfo }
  55.     function InterfaceSupportsErrorInfo(const iid: TIID): HResult; stdcall;
  56.   public
  57.     constructor Create(const AppServer: IAppServerDisp);
  58.     function SafeCallException(ExceptObject: TObject;
  59.       ExceptAddr: Pointer): HResult; override;
  60.   end;
  61.  
  62.   { TDispatchConnection }
  63.  
  64.   TGetUsernameEvent = procedure(Sender: TObject; var Username: string) of object;
  65.  
  66.   TDispatchConnection = class(TCustomRemoteServer)
  67.   private
  68.     FServerGUID: TGUID;
  69.     FServerName: string;
  70.     FAppServer: Variant;
  71.     FObjectBroker: TCustomObjectBroker;
  72.     FOnGetUsername: TGetUsernameEvent;
  73.     function GetServerGUID: string;
  74.     procedure SetServerGUID(const Value: string);
  75.     procedure SetServerName(const Value: string);
  76.     procedure SetObjectBroker(Value: TCustomObjectBroker);
  77.   protected
  78.     function GetServerList: OleVariant; override;
  79.     function GetAppServer: Variant; virtual;
  80.     procedure SetAppServer(Value: Variant); virtual;
  81.     procedure DoDisconnect; override;
  82.     function GetConnected: Boolean; override;
  83.     procedure SetConnected(Value: Boolean); override;
  84.     procedure GetProviderNames(Proc: TGetStrProc); override;
  85.     function GetServerCLSID: TGUID;
  86.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  87.     property ObjectBroker: TCustomObjectBroker read FObjectBroker write SetObjectBroker;
  88.   public
  89.     constructor Create(AOwner: TComponent); override;
  90.     function GetServer: IAppServer; override;
  91.     property AppServer: Variant read GetAppServer;
  92.   published
  93.     property Connected;
  94.     property LoginPrompt default False;
  95.     property ServerGUID: string read GetServerGUID write SetServerGUID;
  96.     property ServerName: string read FServerName write SetServerName;
  97.     property AfterConnect;
  98.     property AfterDisconnect;
  99.     property BeforeConnect;
  100.     property BeforeDisconnect;
  101.     property OnGetUsername: TGetUsernameEvent read FOnGetUsername write FOnGetUsername;
  102.     property OnLogin;
  103.   end;
  104.  
  105.   { TCOMConnection }
  106.  
  107.   TCOMConnection = class(TDispatchConnection)
  108.   protected
  109.     procedure SetConnected(Value: Boolean); override;
  110.     procedure DoConnect; override;
  111.   end;
  112.  
  113.   { TDCOMConnection }
  114.  
  115.   TDCOMConnection = class(TCOMConnection)
  116.   private
  117.     FComputerName: string;
  118.     procedure SetComputerName(const Value: string);
  119.     function IsComputerNameStored: Boolean;
  120.   protected
  121.     procedure DoConnect; override;
  122.   public
  123.     constructor Create(AOwner: TComponent); override;
  124.   published
  125.     property ComputerName: string read FComputerName write SetComputerName stored IsComputerNameStored;
  126.     property ObjectBroker;
  127.   end;
  128.  
  129.   { TOLEnterpriseConnection }
  130.  
  131.   TOLEnterpriseConnection = class(TCOMConnection)
  132.   private
  133.     FComputerName: string;
  134.     FBrokerName: string;
  135.     procedure SetComputerName(const Value: string);
  136.     procedure SetBrokerName(const Value: string);
  137.   protected
  138.     procedure DoConnect; override;
  139.   published
  140.     property ComputerName: string read FComputerName write SetComputerName;
  141.     property BrokerName: string read FBrokerName write SetBrokerName;
  142.   end;
  143.  
  144.   procedure GetMIDASAppServerList(List: TStringList; const RegCheck: string);
  145.  
  146. implementation
  147.  
  148. uses
  149.   Forms, Registry, MidConst, DBLogDlg, Provider;
  150.  
  151. procedure GetMIDASAppServerList(List: TStringList; const RegCheck: string);
  152. var
  153.   EnumGUID: IEnumGUID;
  154.   Fetched: Cardinal;
  155.   Guid: TGUID;
  156.   Rslt: HResult;
  157.   CatInfo: ICatInformation;
  158.   I, BufSize: Integer;
  159.   ClassIDKey: HKey;
  160.   S: string;
  161.   Buffer: array[0..255] of Char;
  162. begin
  163.   List.Clear;
  164.   Rslt := CoCreateInstance(CLSID_StdComponentCategoryMgr, nil,
  165.     CLSCTX_INPROC_SERVER, ICatInformation, CatInfo);
  166.   if Succeeded(Rslt) then
  167.   begin
  168.     OleCheck(CatInfo.EnumClassesOfCategories(1, @CATID_MIDASAppServer, 0, nil, EnumGUID));
  169.     while EnumGUID.Next(1, Guid, Fetched) = S_OK do
  170.     begin
  171.       if RegCheck <> '' then
  172.       begin
  173.         S := SClsid + GuidToString(Guid) + '\';
  174.         if GetRegStringValue(S, RegCheck) <> SFlagOn then continue;
  175.       end;
  176.       List.Add(ClassIDToProgID(Guid));
  177.     end;
  178.   end else
  179.   begin
  180.     if RegOpenKey(HKEY_CLASSES_ROOT, 'CLSID', ClassIDKey) <> 0 then
  181.       try
  182.         I := 0;
  183.         while RegEnumKey(ClassIDKey, I, Buffer, SizeOf(Buffer)) = 0 do
  184.         begin
  185.           S := Format('%s\Implemented Categories\%s',[Buffer,
  186.             GUIDToString(CATID_MIDASAppServer)]);
  187.           if RegQueryValue(ClassIDKey, PChar(S), nil, BufSize) = 0 then
  188.             if RegCheck <> '' then
  189.             begin
  190.               BufSize := 256;
  191.               SetLength(S, BufSize);
  192.               if RegQueryValueEx(ClassIDKey, PChar(RegCheck), nil, nil,
  193.                     PByte(PChar(S)), @BufSize) = ERROR_SUCCESS then
  194.                 SetLength(S, BufSize - 1) else
  195.                 S := '';
  196.               if GetRegStringValue(S, RegCheck) <> SFlagOn then continue;
  197.             end;
  198.           List.Add(ClassIDToProgID(StringToGUID(Buffer)));
  199.           Inc(I);
  200.         end;
  201.       finally
  202.         RegCloseKey(ClassIDKey);
  203.       end;
  204.   end;
  205. end;
  206.  
  207. { TDispatchAppServer }
  208.  
  209. constructor TDispatchAppServer.Create(const AppServer: IAppServerDisp);
  210. begin
  211.   inherited Create;
  212.   FAppServer := AppServer;
  213. end;
  214.  
  215. { TDispatchAppServer.IDispatch }
  216.  
  217. function TDispatchAppServer.GetTypeInfoCount(out Count: Integer): HResult;
  218. begin
  219.   Result := IDispatch(FAppServer).GetTypeInfoCount(Count);
  220. end;
  221.  
  222. function TDispatchAppServer.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
  223. begin
  224.   Result := IDispatch(FAppServer).GetTypeInfo(Index, LocaleID, TypeInfo);
  225. end;
  226.  
  227. function TDispatchAppServer.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  228.   NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
  229. begin
  230.   Result := IDispatch(FAppServer).GetIDsOfNames(IID, Names, NameCount, LocaleID, DispIDs);
  231. end;
  232.  
  233. function TDispatchAppServer.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  234.   Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
  235. begin
  236.   Result := IDispatch(FAppServer).Invoke(DispID, IID, LocaleID, Flags, Params,
  237.     VarResult, ExcepInfo, ArgErr);
  238. end;
  239.  
  240. { TDispatchAppServer.IAppServer }
  241.  
  242. function TDispatchAppServer.AS_ApplyUpdates(const ProviderName: WideString;
  243.   Delta: OleVariant; MaxErrors: Integer; out ErrorCount: Integer;
  244.   var OwnerData: OleVariant): OleVariant; safecall;
  245. begin
  246.   Result := FAppServer.AS_ApplyUpdates(ProviderName, Delta, MaxErrors, ErrorCount,
  247.     OwnerData);
  248. end;
  249.  
  250. function TDispatchAppServer.AS_GetRecords(const ProviderName: WideString;
  251.   Count: Integer; out RecsOut: Integer; Options: Integer; const CommandText: WideString; var Params,
  252.   OwnerData: OleVariant): OleVariant; safecall;
  253. begin
  254.   Result := FAppServer.AS_GetRecords(ProviderName, Count, RecsOut, Options, CommandText, Params,
  255.     OwnerData);
  256. end;
  257.  
  258. function TDispatchAppServer.AS_DataRequest(const ProviderName: WideString;
  259.   Data: OleVariant): OleVariant; safecall;
  260. begin
  261.   Result := FAppServer.AS_DataRequest(ProviderName, Data);
  262. end;
  263.  
  264. function TDispatchAppServer.AS_GetProviderNames: OleVariant;
  265. begin
  266.   Result := FAppServer.AS_GetProviderNames;
  267. end;
  268.  
  269. function TDispatchAppServer.AS_GetParams(const ProviderName: WideString;
  270.   var OwnerData: OleVariant): OleVariant;
  271. begin
  272.   Result := FAppServer.AS_GetParams(ProviderName, OwnerData);
  273. end;
  274.  
  275. function TDispatchAppServer.AS_RowRequest(const ProviderName: WideString;
  276.   Row: OleVariant; RequestType: Integer; var OwnerData: OleVariant): OleVariant;
  277. begin
  278.   Result := FAppServer.AS_RowRequest(ProviderName, Row, RequestType, OwnerData);
  279. end;
  280.  
  281. procedure TDispatchAppServer.AS_Execute(const ProviderName: WideString;
  282.   const CommandText: WideString; var Params, OwnerData: OleVariant);
  283. begin
  284.   FAppServer.AS_Execute(ProviderName, CommandText, Params, OwnerData);
  285. end;
  286.  
  287. { TDispatchAppServer.ISupportErrorInfo }
  288.  
  289. function TDispatchAppServer.InterfaceSupportsErrorInfo(const iid: TIID): HResult;
  290. begin
  291.   if IsEqualGUID(IAppServer, iid) then
  292.     Result := S_OK else
  293.     Result := S_FALSE;
  294. end;
  295.  
  296. function TDispatchAppServer.SafeCallException(ExceptObject: TObject;
  297.   ExceptAddr: Pointer): HResult;
  298. begin
  299.   Result := HandleSafeCallException(ExceptObject, ExceptAddr, IAppServer, '', '');
  300. end;
  301.  
  302. { TDispatchConnection }
  303.  
  304. constructor TDispatchConnection.Create(AOwner: TComponent);
  305. begin
  306.   inherited Create(AOwner);
  307.   LoginPrompt := False;
  308. end;
  309.  
  310. function TDispatchConnection.GetServerList: OleVariant;
  311. var
  312.   List: TStringList;
  313.   i: Integer;
  314. begin
  315.   Result := NULL;
  316.   List := TStringList.Create;
  317.   try
  318.     GetMIDASAppServerList(List, '');
  319.     if List.Count > 0 then
  320.     begin
  321.       Result := VarArrayCreate([0, List.Count - 1], varOleStr);
  322.       for i := 0 to List.Count - 1 do
  323.         Result[i] := List[i];
  324.     end;
  325.   finally
  326.     List.Free;
  327.   end;
  328. end;
  329.  
  330. procedure TDispatchConnection.Notification(AComponent: TComponent;
  331.   Operation: TOperation);
  332. begin
  333.   inherited Notification(AComponent, Operation);
  334.   if (Operation = opRemove) and (AComponent = FObjectBroker) then
  335.     FObjectBroker := nil;
  336. end;
  337.  
  338. procedure TDispatchConnection.SetObjectBroker(Value: TCustomObjectBroker);
  339. begin
  340.   if Value = FObjectBroker then Exit;
  341.   if Assigned(Value) then
  342.     Value.FreeNotification(Self);
  343.   FObjectBroker := Value;
  344. end;
  345.  
  346. function TDispatchConnection.GetServerGUID: string;
  347. begin
  348.   if (FServerGUID.D1 <> 0) or (FServerGUID.D2 <> 0) or (FServerGUID.D3 <> 0) then
  349.     Result := GUIDToString(FServerGUID) else
  350.     Result := '';
  351. end;
  352.  
  353. procedure TDispatchConnection.SetServerGUID(const Value: string);
  354. var
  355.   ServerName: PWideChar;
  356. begin
  357.   if not (csLoading in ComponentState) then
  358.     SetConnected(False);
  359.   if Value = '' then
  360.     FillChar(FServerGUID, SizeOf(FServerGUID), 0)
  361.   else
  362.   begin
  363.     FServerGUID := StringToGUID(Value);
  364.     if ProgIDFromCLSID(FServerGUID, ServerName) = 0 then
  365.     begin
  366.       FServerName := ServerName;
  367.       CoTaskMemFree(ServerName);
  368.     end;
  369.   end;
  370. end;
  371.  
  372. procedure TDispatchConnection.SetServerName(const Value: string);
  373. begin
  374.   if Value <> FServerName then
  375.   begin
  376.     if not (csLoading in ComponentState) then
  377.     begin
  378.       SetConnected(False);
  379.       if CLSIDFromProgID(PWideChar(WideString(Value)), FServerGUID) <> 0 then
  380.         FillChar(FServerGUID, SizeOf(FServerGUID), 0);
  381.     end;
  382.     FServerName := Value;
  383.   end;
  384. end;
  385.  
  386. function TDispatchConnection.GetConnected: Boolean;
  387. begin
  388.   Result := (not VarIsNull(AppServer) and (IDispatch(AppServer) <> nil));
  389. end;
  390.  
  391. procedure TDispatchConnection.SetConnected(Value: Boolean);
  392. var
  393.   Username, Password: string;
  394.   Login: Boolean;
  395. begin
  396.   Login := LoginPrompt and Value and not Connected and not (csDesigning in ComponentState);
  397.   if Login then
  398.   begin
  399.     if Assigned(FOnGetUsername) then FOnGetUsername(Self, Username);
  400.     if not RemoteLoginDialog(Username, Password) then SysUtils.Abort;
  401.   end;
  402.   inherited SetConnected(Value);
  403.   if Login and Connected then
  404.     if Assigned(OnLogin) then OnLogin(Self, Username, Password);
  405. end;
  406.  
  407. procedure TDispatchConnection.DoDisconnect;
  408. begin
  409.   SetAppServer(NULL);
  410. end;
  411.  
  412. function TDispatchConnection.GetAppServer: Variant;
  413. begin
  414.   Result := FAppServer;
  415. end;
  416.  
  417. procedure TDispatchConnection.SetAppServer(Value: Variant);
  418. begin
  419.   FAppServer := Value;
  420. end;
  421.  
  422. function TDispatchConnection.GetServer: IAppServer;
  423. var
  424.   QIResult: HResult;
  425. begin
  426.   Connected := True;
  427.   QIResult := IDispatch(FAppServer).QueryInterface(IAppServer, Result);
  428.   if QIResult <> S_OK then
  429.     Result := TDispatchAppServer.Create(IAppServerDisp(IDispatch(FAppServer)));
  430. end;
  431.  
  432. procedure TDispatchConnection.GetProviderNames(Proc: TGetStrProc);
  433. var
  434.   List: Variant;
  435.   I: Integer;
  436. begin
  437.   Connected := True;
  438.   VarClear(List);
  439.   try
  440.     List := AppServer.AS_GetProviderNames;
  441.   except
  442.     { Assume any errors means the list is not available. }
  443.   end;
  444.   if VarIsArray(List) and (VarArrayDimCount(List) = 1) then
  445.     for I := VarArrayLowBound(List, 1) to VarArrayHighBound(List, 1) do
  446.       Proc(List[I]);
  447. end;
  448.  
  449. function TDispatchConnection.GetServerCLSID: TGUID;
  450. begin
  451.   if IsEqualGuid(FServerGuid, GUID_NULL) then
  452.   begin
  453.     if FServerName = '' then
  454.       raise Exception.CreateResFmt(@SServerNameBlank, [Name]);
  455.     Result := ProgIDToClassID(FServerName);
  456.   end else
  457.     Result := FServerGuid;
  458. end;
  459.  
  460. { TCOMConnection }
  461.  
  462. procedure TCOMConnection.SetConnected(Value: Boolean);
  463. begin
  464.   if (not (csReading in ComponentState)) and
  465.      (Value and not Connected) and
  466.      IsEqualGuid(GetServerCLSID, GUID_NULL) then
  467.     raise Exception.CreateResFmt(@SServerNameBlank, [Name]);
  468.   inherited SetConnected(Value);
  469. end;
  470.  
  471. procedure TCOMConnection.DoConnect;
  472. begin
  473.   SetAppServer(CreateComObject(GetServerCLSID) as IDispatch);
  474. end;
  475.  
  476. { TDCOMConnection }
  477.  
  478. constructor TDCOMConnection.Create(AOwner: TComponent);
  479. begin
  480.   inherited Create(AOwner);
  481. end;
  482.  
  483. procedure TDCOMConnection.SetComputerName(const Value: string);
  484. begin
  485.   if Value <> FComputerName then
  486.   begin
  487.     SetConnected(False);
  488.     FComputerName := Value;
  489.   end;
  490. end;
  491.  
  492. function TDCOMConnection.IsComputerNameStored: Boolean;
  493. begin
  494.   Result := (FObjectBroker = nil) and (ComputerName <> '');
  495. end;
  496.  
  497. procedure TDCOMConnection.DoConnect;
  498. begin
  499.   if (FObjectBroker <> nil) then
  500.   begin
  501.     repeat
  502.       if FComputerName = '' then
  503.         FComputerName := FObjectBroker.GetComputerForGUID(GetServerCLSID);
  504.       try
  505.         SetAppServer(CreateRemoteComObject(ComputerName, GetServerCLSID) as IDispatch);
  506.         FObjectBroker.SetConnectStatus(ComputerName, True);
  507.       except
  508.         FObjectBroker.SetConnectStatus(ComputerName, False);
  509.         FComputerName := '';
  510.       end;
  511.     until Connected;
  512.   end else if (ComputerName <> '') then
  513.     SetAppServer(CreateRemoteComObject(ComputerName, GetServerCLSID) as IDispatch) else
  514.     inherited DoConnect;
  515. end;
  516.  
  517. { TOLEnterpriseConnection }
  518.  
  519. procedure TOLEnterpriseConnection.SetComputerName(const Value: string);
  520. begin
  521.   if Value <> FComputerName then
  522.   begin
  523.     SetConnected(False);
  524.     FComputerName := Value;
  525.   end;
  526.   if Value <> '' then
  527.     FBrokerName := '';
  528. end;
  529.  
  530. procedure TOLEnterpriseConnection.SetBrokerName(const Value: string);
  531. begin
  532.   if Value <> FBrokerName then
  533.   begin
  534.     SetConnected(False);
  535.     FBrokerName := Value;
  536.   end;
  537.   if Value <> '' then
  538.     FComputerName := '';
  539. end;
  540.  
  541. procedure TOLEnterpriseConnection.DoConnect;
  542. var
  543.   Reg: TRegistry;
  544.  
  545.   procedure WriteValue(ValueName, Value: String);
  546.   begin
  547.     if not Reg.ValueExists(ValueName) then
  548.       Reg.WriteString(ValueName, Value);
  549.   end;
  550.  
  551. const
  552.   AgentDLL = 'oleaan40.dll';
  553. var
  554.   InprocKey, Inproc2Key, DllName, TempStr, TempStr2, ProgID: String;
  555. begin
  556.   Reg := TRegistry.Create;
  557.   try
  558.     Reg.RootKey := HKEY_LOCAL_MACHINE;
  559.     if Reg.OpenKey('Software\OpenEnvironment\InstallRoot', False) then
  560.     begin
  561.       DllName := Reg.ReadString('');
  562.       Reg.CloseKey;
  563.       if Reg.OpenKey('Software\OpenEnvironment\OLEnterprise\AutomationAgent', False) then
  564.       begin 
  565.         if not IsPathDelimiter(DllName, Length(DllName)) then DllName := DllName + '\';
  566.         DllName := DllName + Reg.ReadString(''); 
  567.         Reg.CloseKey;
  568.       end else
  569.       begin
  570.         if not IsPathDelimiter(DllName, Length(DllName)) then DllName := DllName + '\';
  571.         DllName := DllName + AgentDLL;
  572.       end;
  573.     end else
  574.       DllName := AgentDLL; { AgentDLL must be in the path }
  575.     Reg.RootKey := HKEY_CLASSES_ROOT;
  576.     InprocKey := Format('CLSID\%s\InprocServer32', [ServerGUID]);
  577.     Inproc2Key := Format('CLSID\%s\_InprocServer32', [ServerGUID]);
  578.     if (ComputerName = '') and (BrokerName = '') then {Run via COM}
  579.     begin
  580.       if Reg.OpenKey(InprocKey, False) then
  581.       begin
  582.         TempStr := Reg.ReadString('');
  583.         Reg.CloseKey;
  584.         if (AnsiPos(AgentDLL, AnsiLowerCase(TempStr)) > 0) or
  585.            (AnsiPos(AnsiLowerCase(ExtractFileName(DllName)), AnsiLowerCase(TempStr)) > 0) then
  586.         begin
  587.           if Reg.OpenKey(Inproc2Key, False) then
  588.           begin
  589.             TempStr2 := Reg.ReadString('');
  590.             Reg.WriteString('',TempStr);
  591.             Reg.CloseKey;
  592.             Reg.OpenKey(InprocKey, False);
  593.             Reg.WriteString('',TempStr2);
  594.             Reg.CloseKey;
  595.           end else
  596.             Reg.DeleteKey(InprocKey);
  597.         end;
  598.       end;
  599.     end else
  600.     begin
  601.       if Reg.OpenKey(InprocKey, False) then
  602.       begin
  603.         TempStr := Reg.ReadString('');
  604.         Reg.CloseKey;
  605.         if (AnsiPos(AgentDLL, AnsiLowerCase(TempStr)) = 0) and
  606.            (AnsiPos(AnsiLowerCase(ExtractFileName(DllName)), AnsiLowerCase(TempStr)) = 0) then
  607.           Reg.MoveKey(InprocKey, Inproc2Key, True);
  608.       end;
  609.       Reg.OpenKey(InprocKey, True);
  610.       Reg.WriteString('',DllName);
  611.       Reg.WriteString('ThreadingModel','Apartment');
  612.       Reg.CloseKey;
  613.       Reg.RootKey := HKEY_LOCAL_MACHINE;
  614.       Reg.OpenKey('Software\OpenEnvironment\OLEnterprise\Dap\DCEApp',True);
  615.       if BrokerName <> '' then
  616.       begin
  617.         Reg.WriteString('Broker',Format('ncacn_ip_tcp:%s',[BrokerName]));
  618.         WriteValue('LogLevel', '0');
  619.         WriteValue('LogFile','');
  620.         WriteValue('UseNaming','1');
  621.         WriteValue('UseSecurity','1');
  622.       end else
  623.         Reg.WriteString('Broker','none');
  624.       Reg.CloseKey;
  625.       Reg.RootKey := HKEY_CLASSES_ROOT;
  626.       if Reg.OpenKey(Format('CLSID\%s\ProgID',[ServerGUID]), False) then
  627.       begin
  628.         ProgID := Reg.ReadString('');
  629.         Reg.CloseKey;
  630.       end else
  631.       begin
  632.         ProgID := ServerName;
  633.         if ProgID = '' then
  634.           ProgID := ServerGUID else
  635.         begin
  636.           Reg.OpenKey(Format('%s\CLSID',[ProgID]), True);
  637.           Reg.WriteString('',ServerGUID);
  638.           Reg.CloseKey;
  639.         end;
  640.         Reg.OpenKey(Format('CLSID\%s\ProgID',[ServerGUID]), True);
  641.         Reg.WriteString('',ProgID);
  642.         Reg.CloseKey;
  643.       end;
  644.       Reg.OpenKey(Format('CLSID\%s\Dap\DCEClient\%s',[ServerGUID, ProgID]), True);
  645.       WriteValue('ComTimeout','default');
  646.       Reg.WriteString('DisableNaming',IntToStr(Ord(BrokerName = '')));
  647.       WriteValue('ExtendedImport','1');
  648.       WriteValue('ImportName','%cell%/applications/services/%service%');
  649.       WriteValue('ProtectionLevel','');
  650.       WriteValue('Protseq','ncacn_ip_tcp');
  651.       if BrokerName <> '' then
  652.         Reg.DeleteValue('ServerBinding') else
  653.         Reg.WriteString('ServerBinding',Format('ncacn_ip_tcp:%s',[ComputerName]));
  654.       WriteValue('ServerPrincipal','');
  655.       WriteValue('SetAuthentication','1');
  656.       WriteValue('TimerInterval','10');
  657.       WriteValue('VerifyAvailability','0');
  658.       Reg.CloseKey;
  659.       Reg.CreateKey(Format('CLSID\%s\NotInsertable',[ServerGUID]));
  660.       Reg.CreateKey(Format('CLSID\%s\Programmable',[ServerGUID]));
  661.     end;
  662.   finally
  663.     Reg.Free;
  664.   end;
  665.   inherited DoConnect;
  666. end;
  667.  
  668. end.
  669.