Prototyp für Singleton und Callbacks mit mehrere Clients

[imad Katit]

Hallo,
in meinem Prototyp habe ich die Singleton und Callbacks kombiniert.
Zugriff auf einen COM-Server Instanz und die Benachrichtigung von allem angemeldeten Client funktionieren einwandfrei.
Beim Schließen von einem Client bekomme ich die Meldung „Diese
Anwendung enthält noch aktive Com-Objekte“

Wie kann ich diese Meldung weg kriege ohne ich COM-Server von den Client-Seite zerstöre.
Ich möchte das Singleton-Obj nicht zerstören, damit anderen Clients neue anmelden können.

Mein Code sieht so aus:
--------
unit ServerTest_Impl;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
ComObj, ActiveX, ServerTest_TLB, StdVcl, Classes;
type
TSingeltonAutoObjectFactory = class(TAutoObjectFactory)
private
FCOMObj : TComObject;
protected
{ Protected-Deklarationen }
function CreateComObject(const Controller: IUnknown): TComObject; override;
destructor Destroy; override;
end;
type
TServer = class(TAutoObject, IServer)
private
FDaten :String;
FLagermodulHandle : Integer;
FClientCount : Integer;
FMGGruppeList : Boolean;
FBeobachterList : TInterfaceList;
protected
function Get_Daten: WideString; safecall;
procedure MeldeAb(const Beob: IBeobachter); safecall;
procedure MeldeAn(const Beob: IBeobachter; CltID: Integer); safecall;
procedure Set_Daten(const Value: WideString); safecall;
procedure BeobachternBenachrichtigen(const MSG: WideString); safecall;
{ Protected-Deklarationen }
public
procedure Initialize; override;
constructor create;
destructor Destroy; override;
end;

implementation

uses ComServ, SysUtils, ServerTestFrm;

var
iGlobalCount : Integer;

constructor TServer.create;
begin
FMGGruppeList := False;
end;

destructor TServer.Destroy;
begin
RevokeActiveObject(FLagermodulHandle, nil);
inherited;
end;

function TServer.Get_Daten: WideString;
begin
Get_Daten := FDaten;
end;

procedure TServer.Initialize;
begin
inherited;
RegisterActiveObject(Self as IUnknown, Class_Server,
ACTIVEOBJECT_WEAK, FLagermodulHandle);
end;

procedure TServer.MeldeAb(const Beob: IBeobachter);
var i:Integer;
begin
if (FBeobachterList <> nil) and (FBeobachterList.Count>0) then
begin
i := FBeobachterList.IndexOf(Beob);
FBeobachterList.Delete(i);
end;
ServerDlg.ListBox1.Items.Add('Aufruf MeldeAb');
end;

procedure TServer.MeldeAn(const Beob: IBeobachter; CltID: Integer);
var i:Integer;
FBeobachter: IBeobachter;
s : String;
begin
Inc(FClientCount);
Inc(iGlobalCount);
if FBeobachterList = nil then
FBeobachterList := TInterfaceList.Create;
i := FBeobachterList.Add(Beob);
FBeobachter := IBeobachter(FBeobachterList[i]);
FBeobachter.Aktualisiere('Aufruf MeldeAn');
ServerDlg.ListBox1.Items.Add(Format('Aufruf MeldeAn %d ', [CltID]));
end;

procedure TServer.Set_Daten(const Value: WideString);
begin
FDaten := Value;
Inc(iGlobalCount);
BeobachternBenachrichtigen(FDaten);
end;

{ TSingeltonAutoObjectFactory }

function TSingeltonAutoObjectFactory.CreateComObject(
const Controller: IInterface): TComObject;
begin
if FCOMObj = nil then
FCOMObj := inherited CreateComObject(Controller);
Result := FCOMObj;
end;

destructor TSingeltonAutoObjectFactory.Destroy;
begin
FCOMObj := nil;
inherited;
end;

procedure TServer.BeobachternBenachrichtigen(const MSG: WideString);
var i :integer;
begin
if FBeobachterList <> nil then
begin
for i:=0 to FBeobachterList.Count-1 do
begin //Beob. Benachrichtigen
IBeobachter(FBeobachterList[i]).Aktualisiere(Msg);
end;
ServerDlg.ListBox1.Items.Add('Aufruf Beo. Benachrichtigen '+Msg+inttostr(i));
end;
end;

initialization
TSingeltonAutoObjectFactory.Create(ComServer, TServer, Class_Server,
ciMultiInstance, tmApartment);
end.
------------
unit ClientTestFrm;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls, ServerTest_TLB,ClientTest_TLB, ComObj;

type
TClientDlg = class(TForm)
ButtonClose: TButton;
Edit1: TEdit;
Edit2: TEdit;
DatentZuSrv: TButton;
DatenVonSrv: TButton;
ListBox1: TListBox;
Anmelden: TButton;
Abmelden: TButton;
procedure DatentZuSrvClick(Sender: TObject);
procedure DatenVonSrvClick(Sender: TObject);
procedure AnmeldenClick(Sender: TObject);
procedure AbmeldenClick(Sender: TObject);
procedure ButtonCloseClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private-Deklarationen }
FServerTest : IServer;
FBeobachter : IBeobachter;
FAngemeldet : Boolean;
procedure BeobachterAbmelden;
public
{ Public-Deklarationen }
end;

var
ClientDlg: TClientDlg;

implementation
uses ActiveX;
{$R *.dfm}

{ TForm1 }

procedure TClientDlg.BeobachterAbmelden;
begin
if(FAngemeldet)then
begin
FServerTest.MeldeAb(FBeobachter);
FAngemeldet := False;
end;
end;

procedure TClientDlg.DatentZuSrvClick(Sender: TObject);
begin
FServerTest.Daten := Edit1.Text;
end;

procedure TClientDlg.DatenVonSrvClick(Sender: TObject);
begin
Edit2.Text := FServerTest.Daten;
end;

procedure TClientDlg.AnmeldenClick(Sender: TObject);
begin
if(not FAngemeldet)then
begin
FServerTest.MeldeAn(FBeobachter,GetCurrentThreadID );
FAngemeldet := True;
end;
end;

procedure TClientDlg.AbmeldenClick(Sender: TObject);
begin
BeobachterAbmelden;
end;

procedure TClientDlg.ButtonCloseClick(Sender: TObject);
begin
Close
end;

procedure TClientDlg.FormCreate(Sender: TObject);
var aSrvObj : IUnknown;
begin
{ FCallbackSrv := CoCBServer.Create;
FCallback := CoCallbackObj.Create as ICallback; }
GetActiveObject(CLASS_Server, nil, aSrvObj);
if Assigned(aSrvObj) then
begin
FServerTest := aSrvObj as IServer;
// MsgAnSrv := 'Connect mit ROT-Instanz';
end
else
begin
FServerTest := CoServer.Create;
// MsgAnSrv := 'Connect mit neuer Instanz';
end;
FAngemeldet := False;
FBeobachter := CoClientTest.Create as IBeobachter;
//FCBServerTest.MeldeAn(FBeobachter);
end;

end.
--------------
unit ClientTest_Impl;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
ComObj, ActiveX, ClientTest_TLB, StdVcl, ServerTest_TLB;

type
TClientTest = class(TAutoObject, IClientTest, IBeobachter)

protected
{ Protected-Deklarationen }
procedure Aktualisiere(const MSG: WideString); safecall;
end;

implementation

uses ComServ, ClientTestFrm;

{ TClientTest }

{ TClientTest }

procedure TClientTest.Aktualisiere(const MSG: WideString);
begin

try
ClientDlg.ListBox1.Items.Add(MSG);
except
end;
end;

initialization
TAutoObjectFactory.Create(ComServer, TClientTest, Class_ClientTest,
ciMultiInstance, tmApartment);
end.