Solved

[COM] System-wide singleton COM component...

Posted on 2004-08-25
16
402 Views
Last Modified: 2010-04-04
Okay, simple question. I need sample code of a COM/ActiveX systemwide singleton component. In other words, it is created only once and applications that call this component will get access to this component. Thus, a component that can share data between many applications.

"This is impossible" is worth 0 points. A working example will receive 500 points with an A grade. Anything else will only be awarded if no working example is provided within the next two days. (I will close this Q within 2 days anyway.)

Yes guys (and girls), this is a challenge! In two days I will have time to solve it myself. But this might save me some time. ;-)
0
Comment
Question by:Wim ten Brink
  • 5
  • 5
  • 4
  • +1
16 Comments
 
LVL 12

Expert Comment

by:Ivanov_G
ID: 11892553
File / New / Other / ActiveX  and COM Object

for Instancing choose Single Instance. Threading Model: Single

Working with COM like this this, you will have to use Critical Sections when you use global resources, like ADOQuery for example or global variable. This can reflect on the performance...
0
 
LVL 17

Author Comment

by:Wim ten Brink
ID: 11892740
Ehm, it is a bit more complex than this... I forgot to add something, I noticed... The COM component must send an event to ALL connected applications under certain conditions. Thus, application A executes a method, and the method fires an event on A, B, C, ... for all attached applications...

In other words, the system must be data-aware...
0
 
LVL 12

Expert Comment

by:Ivanov_G
ID: 11893157
if you are going to write data-aware application, you should use Multithreaded COM. This is the better solution...
There is a class TRemoteDataModule. Use it to define your COM interface.
0
 
LVL 17

Author Comment

by:Wim ten Brink
ID: 11893995
Ehm, I found what I was looking for already.
http://www.blong.com/Conferences/IConUK2000/DelphiMoreAutomation/More%20Automation%20In%20Delphi.htm offers more information about the techniques I need. Too bad he dared to call his COM component TApplication in the client applications. A sure way to create lots of conflicts... And another nasty trick is that this source code is polling the latest information all the time.

And by data-aware I just meant that all clients must respond to changes in the services. Nothing database-related and nothing complicated either. Still, not wanting to waste 500 good points, I'll reward them to whomever can find similar examples. :-)
0
 
LVL 12

Expert Comment

by:Lee_Nover
ID: 11899917
a simple observer pattern :)
when the com obj is acquired a method should be called like 'COMObj.RegisterObserver(ReferenceToMe)' which would add a reference of somesort (a window handle, event handle, ...) to a list
maybe there's a way to do this automaticaly like with _AddRef in interfaces
then when any other methods that require notifications get called the comobject would traverse the list and notify the Observers

I just might create an example .. sounds fun .. but time is not on my side :)
0
 
LVL 17

Author Comment

by:Wim ten Brink
ID: 11902047
Time isn't on my side either... :-)
0
 
LVL 33

Expert Comment

by:Slick812
ID: 11917646
you might have seen this already, about com server, client

http://www.techvanguards.com/stepbystep/comdelphi/

com server with events to clients is not so easy, never did get mine to work right
0
 
LVL 33

Expert Comment

by:Slick812
ID: 11923044
Not sure how this code might help you (or confuse you) ,  I used the Delphi Automation Object wizard to create the  TLB file and the ComSerInCom file, I added code to both files. I hope you are used to working with the Delphi Automation Object wizard, or you will need to mess with it and get to see how it works, no easy task, it helps if you keep all of your results and parameters as Interfaces or OLEVarient types, , I.E. use  BSTR  for all string types
What this server does is allow info sharing between clients, it keeps an Array of the  TNameRec  with FirstNames and lastNames, so  each client can connect to server and add to the array, or read and write to the array. To read or write to the array, you set the IIntFacEvent5.Index to the index of the Array you want, and then read or set the FirstName and LastName of the IIntFacEvent5.

unit ComSerIn_TLB;

{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers.
interface

uses Windows, ActiveX, Classes, Graphics, OleServer, OleCtrls, StdVCL;

const
  // TypeLibrary Major and minor versions
  ComSerInMajorVersion = 1;
  ComSerInMinorVersion = 0;

  LIBID_ComSerIn: TGUID = '{F7987220-F81E-11D8-B122-AC2DC9C49850}';

  IID_IIntFacEvent5: TGUID = '{F7987221-F81E-11D8-B122-AC2DC9C49850}';
  CLASS_IntFacEvent5: TGUID = '{F7987223-F81E-11D8-B122-AC2DC9C49850}';
  IID_ISerEvents3: TGUID = '{F7987225-F81E-11D8-B122-AC2DC9C49850}';
type

  IIntFacEvent5 = interface;
  IIntFacEvent5Disp = dispinterface;
  ISerEvents3 = interface;
  ISerEvents3Disp = dispinterface;

  IntFacEvent5 = IIntFacEvent5;

  IIntFacEvent5 = interface(IDispatch)
    ['{F7987221-F81E-11D8-B122-AC2DC9C49850}']
    function  Get_Index: Integer; safecall;
    procedure Set_Index(Value: Integer); safecall;
    function  Get_High: Integer; safecall;
    procedure Add(const FirstName1: WideString; const LastName1: WideString); safecall;
    function  Get_LastName: WideString; safecall;
    procedure Set_LastName(const Value: WideString); safecall;
    function  Get_FirstName: WideString; safecall;
    procedure Set_FirstName(const Value: WideString); safecall;
    procedure setEvents(const Callback: ISerEvents3; const Name: WideString); safecall;
    function  Get_Connect_ID: Integer; safecall;
    function  Get_NoName: WordBool; safecall;
    procedure Set_NoName(Value: WordBool); safecall;
    property Index: Integer read Get_Index write Set_Index;
    property High: Integer read Get_High;
    property LastName: WideString read Get_LastName write Set_LastName;
    property FirstName: WideString read Get_FirstName write Set_FirstName;
    property Connect_ID: Integer read Get_Connect_ID;
    property NoName: WordBool read Get_NoName write Set_NoName;
  end;

  IIntFacEvent5Disp = dispinterface
    ['{F7987221-F81E-11D8-B122-AC2DC9C49850}']
    property Index: Integer dispid 1;
    property High: Integer readonly dispid 2;
    procedure Add(const FirstName1: WideString; const LastName1: WideString); dispid 3;
    property LastName: WideString dispid 4;
    property FirstName: WideString dispid 5;
    procedure setEvents(const Callback: ISerEvents3; const Name: WideString); dispid 6;
    property Connect_ID: Integer readonly dispid 8;
    property NoName: WordBool dispid 7;
  end;

  ISerEvents3 = interface(IDispatch)
    ['{F7987225-F81E-11D8-B122-AC2DC9C49850}']
    procedure OnChange(NewIndex: Integer); safecall;
    procedure NewName(const nName: WideString); safecall;
    procedure NewHigh(currentHigh: Integer); safecall;
  end;

  ISerEvents3Disp = dispinterface
    ['{F7987225-F81E-11D8-B122-AC2DC9C49850}']
    procedure OnChange(NewIndex: Integer); dispid 1;
    procedure NewName(const nName: WideString); dispid 2;
    procedure NewHigh(currentHigh: Integer); dispid 4;
  end;

  CoIntFacEvent5 = class
    class function Create: IIntFacEvent5;
// The function below was ADDED to this TLB file AFTER the automation object wizard creation
    class function Create_Name(const Callback: ISerEvents3; const Name: WideString): IIntFacEvent5;
    class function CreateRemote(const MachineName: string): IIntFacEvent5;
  end;

implementation

uses ComObj;

class function CoIntFacEvent5.Create: IIntFacEvent5;
begin
  Result := CreateComObject(CLASS_IntFacEvent5) as IIntFacEvent5;
end;

class function CoIntFacEvent5.Create_Name(const Callback: ISerEvents3; const Name: WideString): IIntFacEvent5;
begin
// this function adds the setEvents, so the ISerEvents3 can be placed in the new IIntFacEvent5
Result := CreateComObject(CLASS_IntFacEvent5) as IIntFacEvent5;
if (CallBack <> nil) then
  Result.setEvents(Callback, Name);
end;

class function CoIntFacEvent5.CreateRemote(const MachineName: string): IIntFacEvent5;
begin
  Result := CreateRemoteComObject(MachineName, CLASS_IntFacEvent5) as IIntFacEvent5;
end;

end.


= = = = = = = =  = = = = = =  = = = = =  = = = = = = = = = = =  = = = = = = = = = = =  = = =
= = = = = = = =  = = = = = =  = = = = =  = = = = = = = = = = =  = = = = = = = = = = =  = = =


unit ComSerInCom;

interface

uses
  ComObj, Classes, ActiveX, ComSerIn_TLB, StdVcl;

type
  TNameRec = record
// record in array to share amoung clients
    UserName, FirstName, LastName: WideString;
    ID, AccNum: Integer;
    end;

  TConect1 = class
// This is a class that just stores Each IntFacEvent5 connections data
  public
    FUserName: WideString;
    FID: Integer;
    FNoName: WordBool;
    FCallBack: ISerEvents3;
    destructor Destroy; override;
  end;

  TConectList1 = class
// this is a class that does a TList to store all of the TConect1
  private
    FConList: TList;

  public
    constructor Create;
    destructor Destroy; override;
    procedure setEvents(const Callback: ISerEvents3; const Name: WideString; ID: Integer);
    procedure SetNoName(conID: Integer; NoName: WordBool);
    function GetNoName(conID: Integer): WordBool;
    procedure StopEvents(conID: Integer);
    procedure OnChange(NewIndex: Integer);
    procedure NewName(const nName: WideString);
    procedure NewHigh(currentHigh: Integer);
  end;


  TIntFacEvent5 = class(TAutoObject, IIntFacEvent5)
// this is the Interface Class that is used to add and share information from the Array aryNameRec
  protected
    { Protected declarations }
    FconID: Integer;
    function Get_FirstName: WideString; safecall;
    function Get_High: Integer; safecall;
    function Get_Index: Integer; safecall;
    function Get_LastName: WideString; safecall;
    procedure Add(const FirstName1, LastName1: WideString); safecall;
    procedure Set_FirstName(const Value: WideString); safecall;
    procedure Set_Index(Value: Integer); safecall;
    procedure Set_LastName(const Value: WideString); safecall;
    procedure setEvents(const Callback: ISerEvents3; const Name: WideString);
      safecall;
    //procedure StopEvents; safecall;
    function Get_Connect_ID: Integer; safecall;
    function Get_NoName: WordBool; safecall;
    procedure Set_NoName(Value: WordBool); safecall;

  public
    { Public declarations }
    procedure Initialize; override;
    destructor Destroy; override;
    function getCont: TConectList1;
  end;

implementation

uses ComServ, SysUtils, ComSerIn1;

var
aryNameRec: Array of TNameRec;
ConectNum: Integer = 0; // number of connections to server
AccNum: Integer = 406000;
aHigh: Integer = -1; // current High of aryNameRec
curIndex: Integer = -1; // current Index for aryNameRec access
IDNum: Integer = 100;
ContLst: TConectList1;
// I think it would be better to have created ContLst in the initialization and free in Finalization


destructor TConect1.Destroy;
begin
FCallBack := nil; // free interface reference
inherited Destroy;
end;

//  TConectList1

constructor TConectList1.Create;
begin
FConList := TList.Create;
end;

destructor TConectList1.Destroy;
var
i: Integer;
Con1: TConect1;
begin
for i := 0 to FConList.Count - 1 do
  begin
  Con1 := TConect1(FConList[i]);
  FreeAndNil(Con1);
  end;

inherited Destroy;
end;

procedure TConectList1.setEvents(const Callback: ISerEvents3; const Name: WideString; ID: Integer);
var
Con1: TConect1;
begin
Con1 := TConect1.Create;
Con1.FCallBack := Callback;
Con1.FID := ID{FconID};
Con1.FUserName := Name;
Con1.FNoName := False;
FConList.Add(Con1);
end;

procedure TConectList1.StopEvents(conID: Integer);
var
i: Integer;
Con1: TConect1;
begin
for i := 0 to FConList.Count - 1 do
  begin
  Con1 := TConect1(FConList[i]);
  if Con1.FID = conID then
    begin
    FreeAndNil(Con1);
    FConList.Delete(i);
    end;
  end;
end;

procedure TConectList1.SetNoName(conID: Integer; NoName: WordBool);
var
i: Integer;
begin
for i := 0 to FConList.Count - 1 do
  if TConect1(FConList[i]).FID = conID then
    begin
    TConect1(FConList[i]).FNoName := NoName;
    Break;
    end;
end;

function TConectList1.GetNoName(conID: Integer): WordBool;
var
i: Integer;
begin
Result := False;
for i := 0 to FConList.Count - 1 do
  if TConect1(FConList[i]).FID = conID then
    begin
    Result := TConect1(FConList[i]).FNoName;
    Break;
    end;
end;

// the 3 procedures below are called for the ISerEvents3 events

procedure TConectList1.OnChange(NewIndex: Integer);
var
i: Integer;
begin
for i := 0 to FConList.Count - 1 do
  TConect1(FConList[i]).FCallBack.OnChange(NewIndex);
end;

procedure TConectList1.NewName(const nName: WideString);
var
i: Integer;
begin
for i := 0 to FConList.Count - 1 do
  if not TConect1(FConList[i]).FNoName then
  TConect1(FConList[i]).FCallBack.NewName(nName);
end;

procedure TConectList1.NewHigh(currentHigh: Integer);
var
i: Integer;
begin
for i := 0 to FConList.Count - 1 do
  TConect1(FConList[i]).FCallBack.NewHigh(currentHigh);
end;


// TIntFacEvent5  interface

procedure TIntFacEvent5.Initialize;
begin
inherited Initialize;
Inc(ConectNum);
FconID := IDNum;
Inc(IDNum);
Form1.Label2.Caption := IntToStr(ConectNum)+'  Conections';
end;

destructor TIntFacEvent5.Destroy;
begin
Dec(ConectNum);
getCont.StopEvents(FconID);
Form1.Label2.Caption := IntToStr(ConectNum)+'  Conections';
inherited Destroy;
end;

function TIntFacEvent5.getCont: TConectList1;
begin
if ContLst = nil then
  ContLst := TConectList1.Create;
Result := ContLst;
end;

function TIntFacEvent5.Get_FirstName: WideString;
begin
if curIndex > -1 then
  Result := aryNameRec[curIndex].FirstName
  else
  Result := '';
end;

function TIntFacEvent5.Get_High: Integer;
begin
Result := aHigh;
end;

function TIntFacEvent5.Get_Index: Integer;
begin
Result := curIndex;
end;

function TIntFacEvent5.Get_LastName: WideString;
begin
if curIndex > -1 then
  Result := aryNameRec[curIndex].LastName
  else
  Result := '';
end;

procedure TIntFacEvent5.Add(const FirstName1, LastName1: WideString);
begin
SetLength(aryNameRec, Length(aryNameRec)+1);
aHigh := High(aryNameRec);
aryNameRec[aHigh].LastName := LastName1;
aryNameRec[aHigh].FirstName := FirstName1;
aryNameRec[aHigh].AccNum := AccNum;
Inc(AccNum);

getCont.NewName(aryNameRec[aHigh].FirstName+' '+aryNameRec[aHigh].LastName);
getCont.NewHigh(aHigh);
if curIndex = -1 then
  begin
  curIndex := 0;
  getCont.OnChange(curIndex);
  end;
Form1.Label3.Caption := IntToStr(aHigh)+'  Array High';
end;

procedure TIntFacEvent5.Set_FirstName(const Value: WideString);
begin
if curIndex > -1 then
  aryNameRec[curIndex].FirstName := Value;
end;

procedure TIntFacEvent5.Set_Index(Value: Integer);
begin
if (Value < Length(aryNameRec)) and (Value > -1) then
  begin
  curIndex := Value;
  getCont.OnChange(curIndex);
  end;
end;

procedure TIntFacEvent5.Set_LastName(const Value: WideString);
begin
if curIndex > -1 then
  aryNameRec[curIndex].LastName := Value;
end;

procedure TIntFacEvent5.setEvents(const Callback: ISerEvents3;
  const Name: WideString);
begin
getCont.setEvents(CallBack, Name, FconID);
getCont.NewHigh(aHigh);
getCont.OnChange(curIndex);
end;

function TIntFacEvent5.Get_Connect_ID: Integer;
begin
Result := FconID;
end;

function TIntFacEvent5.Get_NoName: WordBool;
begin
Result := getCont.GetNoName(FconID);
end;

procedure TIntFacEvent5.Set_NoName(Value: WordBool);
begin
getCont.SetNoName(FconID, Value);
end;

initialization
  TAutoObjectFactory.Create(ComServer, TIntFacEvent5, Class_IntFacEvent5,
    ciMultiInstance, tmApartment);
end.


= = = = = = = = = = = = =  = = = = = = = = = = = = = = = = = = = = = =  = = = =

I wanted a server that can be specific for each client, so I created an Interface for the Events, ISerEvents3 which has 3 events that are activated in the client. Also I needed a way to turn on and off some of these events to specific clients, you will see this in the TIntFacEvent5.NoName  boolean, if the client sets this to true, then it will NOT get the  NewName  event, but it will still get the other two (OnChange and NewHigh events).
The form for this has NO code in it just 3 or 4 TLables
0
How to improve team productivity

Quip adds documents, spreadsheets, and tasklists to your Slack experience
- Elevate ideas to Quip docs
- Share Quip docs in Slack
- Get notified of changes to your docs
- Available on iOS/Android/Desktop/Web
- Online/Offline

 
LVL 33

Expert Comment

by:Slick812
ID: 11923057
the code for the  Client form





unit evntComCli1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, OleServer, ActiveX, ComObj, ComSerIn1_TLB;

type
  TEvents1 = class(TAutoIntfObject, ISerEvents3)
    procedure OnChange(NewIndex: Integer); safecall;
    procedure NewName(const nName: WideString); safecall;
    procedure NewHigh(currentHigh: Integer); safecall;
    end;

  TForm1 = class(TForm)
    but_Connect: TButton;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    but_AddNames: TButton;
    but_NoName: TButton;
    Label4: TLabel;
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    but_GetNames: TButton;
    but_SetNames: TButton;
    procedure but_ConnectClick(Sender: TObject);
    procedure but_AddNamesClick(Sender: TObject);
    procedure but_NoNameClick(Sender: TObject);
    procedure but_GetNamesClick(Sender: TObject);
    procedure but_SetNamesClick(Sender: TObject);
  private
    { Private declarations }
    aIndex, curHigh: Integer;
    Server1: IIntFacEvent5;
    Evt1: TEvents1;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}


procedure TEvents1.OnChange(NewIndex: Integer);
begin
Form1.aIndex := NewIndex;
Form1.Label1.Caption := 'Index is '+IntToStr(NewIndex);
end;

procedure TEvents1.NewName(const nName: WideString);
begin
Form1.Label2.Caption := nName;
end;

procedure TEvents1.NewHigh(currentHigh: Integer);
begin
Form1.curHigh := currentHigh;
Form1.Label4.Caption := 'High is '+IntToStr(Form1.curHigh);
end;

procedure TForm1.but_ConnectClick(Sender: TObject);
var
TypLib: ITypeLib;
begin
OLECheck(LoadRegTypeLib(LIBID_ComSerIn,1,0,0, TypLib));
Evt1 := TEvents1.Create(TypLib, ISerEvents3);

if Evt1 <> nil then
  Server1 := CoIntFacEvent5.Create_Name(Evt1, 'Wes1')
  else
  Showmessage('No Evt1');

but_Connect.Enabled := False;
but_AddNames.Enabled := True;
end;

procedure TForm1.but_AddNamesClick(Sender: TObject);
begin
if Server1 <> nil then
  begin
  if Edit1.Text <> '' then
  Server1.Add(Edit1.Text, Edit2.Text);
  end;
end;

procedure TForm1.but_NoNameClick(Sender: TObject);
begin
if Server1 = nil then Exit;
  Server1.NoName := not Server1.NoName;
if Server1.NoName then
  but_NoName.Caption := 'turn NoName OFF'
  else
  but_NoName.Caption := 'turn NoName ON';
end;

procedure TForm1.but_GetNamesClick(Sender: TObject);
var
sIndex: Integer;
begin
if Server1 = nil then Exit;
sIndex := StrToIntDef(Edit3.Text, 0);
if (sIndex < 0) or (sIndex > curHigh) then
  begin
  Showmessage('Index is OUT of BOUNDS');
  Exit;
  end;
Server1.Index := sIndex;
Edit1.Text := Server1.FirstName;
Edit2.Text := Server1.LastName;
end;

procedure TForm1.but_SetNamesClick(Sender: TObject);
var
sIndex: Integer;
begin
if Server1 = nil then Exit;
sIndex := StrToIntDef(Edit3.Text, 0);
if (sIndex < 0) or (sIndex > curHigh) then
  begin
  Showmessage('Index is OUT of BOUNDS');
  Exit;
  end;
Server1.Index := sIndex;
Server1.FirstName := Edit1.Text;
Server1.LastName := Edit2.Text;
end;

end.
0
 
LVL 17

Author Comment

by:Wim ten Brink
ID: 11929561
Slick, thanks for the example but I am not unfamiliar with COM itself. ;-) The biggest problem I have is just making sure I have a singleton COM object. I.E. there's only one object in memory, no matter how many processes are connected to it. Thus, I could have 10 applications using the Object Server1 and they would all be looking at the same object. Thus if process A makes a change to one of the values, it would affect all other processes too. (Thus I want to notify other processes that a value has changed.)

The big problem isn't sharing data between multiple clients. The problem is notifying all clients that something has changed. The problem when you're not using a singleton object for this is that the object itself only knows about one client. The problem with maintaining a list of clients in the server as a global variable is that clients might disappear without these variables being notified about this correctly. Of course there also a few threading issues to consider and a few other nasty problems that need to be solved this way. But there's some existing functionality for this within the COM system and I'm just looking for that.
0
 
LVL 33

Expert Comment

by:Slick812
ID: 11935104
I read your last comment, and I have not com to an understanding of what you mean by  
" singleton COM object "

in my code there is this

TAutoObjectFactory.Create(ComServer, TIntFacEvent5, Class_IntFacEvent5,
    ciMultiInstance, tmApartment);

and as far as I can tell )?, ?) you will nedd to have a  MultiInstance, and  tmApartment  type of come server, I really do NOT think that a single Instance com server will allow you to share any info OR Events, , , but I am not to clear on what you mean by singleton, , anyway. .
as far as I can tell from your last comments, The com server code that I gave you,   does all you have mentioned. .

there is ONE server operational at any time, no matter how many clients there are running

it shares data between several clients, data which is stored on the server

AND with certain data changes (add to the data record, , change Index, , ect) ALL the clients are Notified with a event from the  ISerEvents3 interface, I am under the impression that thread sync is handled by the com interface

also my server keeps a LIST of ALL currently connected clients (and their sign in "Name"), And it has the ability to Turn off and On certain notification events to certain clients (Server1.NoName)

I guess I missed your needs, sorry
0
 
LVL 12

Expert Comment

by:Lee_Nover
ID: 11938687
ofcourse you can do one ...
create a descendant of TAutoObjectFactory that handles the singleton
.. will create an example shortly :)
0
 
LVL 12

Accepted Solution

by:
Lee_Nover earned 500 total points
ID: 11939282
ok .. here's a small example .. should be easy to understand
the observer notification could also be done using event sinks (would also be more flexible and stuff)

the com object impl.
-----------------------

unit MyComObjU;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
  ComObj, Classes, ActiveX, SrvApp_TLB, StdVcl;

type
  TMyComObj = class(TAutoObject, IMyComObj)
  private
    FTotal: Integer;
    FList: TList;
  protected
    procedure Append(AValue: Integer); safecall;
    procedure RegisterObserver(AHandle: Integer); safecall;
    procedure UnRegisterObserver(AHandle: Integer); safecall;
  public
    procedure FreeInstance; override;
    class function NewInstance: TObject; override;
    class function ReferenceCount: Integer;
  end;

  TMyFactory = class(TAutoObjectFactory)
  public
    function CreateComObject(const Controller: IUnknown): TComObject; override;
  end;

implementation

uses ComServ, Windows, Messages, SrvFrmU;

var
  Instance: TMyComObj = nil;
  Ref_Count: Integer = 0;

procedure TMyComObj.FreeInstance;
begin
  InterlockedDecrement(Ref_Count);
  if (Ref_Count = 0) then
  begin
    Instance:=nil;
    FList.Free;
    inherited FreeInstance;
  end;
end;

class function TMyComObj.NewInstance: TObject;
begin
  if (not Assigned(Instance)) then
  begin
    Instance:=TMyComObj(inherited NewInstance);
    with TMyComObj(Instance) do
    begin
      FTotal:=0;
      FList:=TList.Create;
    end;
  end;
  Result:=Instance;
  InterlockedIncrement(Ref_Count);
end;

class function TMyComObj.ReferenceCount: Integer;
begin
  Result:=Ref_Count;
end;

procedure TMyComObj.Append(AValue: Integer);
var wnd, I: Integer;
begin
     FTotal:=FTotal + AValue;
     for I:=FList.Count-1 downto 0 do
     begin
       wnd:=Integer(FList.Items[I]);
       if IsWindow(wnd) then
          PostMessage(wnd, WM_APP + 1, AValue, FTotal)
       else
          UnRegisterObserver(wnd); // unregister nonexistant observers
     end;
end;

procedure TMyComObj.RegisterObserver(AHandle: Integer);
begin
     if FList.IndexOf(Pointer(AHandle)) = -1 then
     begin
       FList.Add(Pointer(AHandle));
       SrvFrm.ObserverRegistered;
     end;
end;

procedure TMyComObj.UnRegisterObserver(AHandle: Integer);
begin
     if FList.Remove(Pointer(AHandle)) > -1 then
        SrvFrm.ObserverUnRegistered;
end;

{ TMyFactory }

function TMyFactory.CreateComObject(
  const Controller: IInterface): TComObject;
begin
     if Assigned(Instance) then
     begin
       Result:=Instance;
     end
     else
       Result:=inherited CreateComObject(Controller);
end;

initialization
  TMyFactory.Create(ComServer, TMyComObj, Class_MyComObj,
    ciMultiInstance, tmSingle);
end.

------------------------------------

test unit
------------------------------------

unit CTestU;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, StdCtrls, SrvApp_TLB, ActiveX;

type
  TCTestF = class(TForm)
    Label1: TLabel;
    Edit1: TEdit;
    Button1: TButton;
    UpDown1: TUpDown;
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    FMyObj: IMyComObj;
    procedure WMAppOne(var AMsg: TMessage); message WM_APP + 1;
  public
    { Public declarations }
  end;

var
  CTestF: TCTestF;

implementation

{$R *.dfm}

{ TCTestF }

procedure TCTestF.WMAppOne(var AMsg: TMessage);
begin
     Memo1.Lines.Add(Format('Value: %d, Total: %d', [AMsg.WParam, AMsg.LParam]));
end;

procedure TCTestF.FormCreate(Sender: TObject);
begin
     FMyObj:=CoMyComObj.Create;
     FMyObj.RegisterObserver(Handle);
end;

procedure TCTestF.FormDestroy(Sender: TObject);
begin
     FMyObj.UnRegisterObserver(Handle);
     FMyObj:=nil;
end;

procedure TCTestF.Button1Click(Sender: TObject);
begin
     FMyObj.Append(UpDown1.Position);
end;

end.
0
 
LVL 12

Expert Comment

by:Lee_Nover
ID: 11939289
the object singleton trick is a reference from: http://howtodothings.com/showarticle.asp?article=170 :)
0
 
LVL 17

Author Comment

by:Wim ten Brink
ID: 11941911
Seems fine to me. :-)
0
 
LVL 12

Expert Comment

by:Lee_Nover
ID: 11949559
in fact you don't need singleton handling at the object level .. only at factory :)
here's the *simpler* version:

unit MyComObjU;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
  ComObj, Classes, ActiveX, SrvApp_TLB, StdVcl;

type
  TMyComObj = class(TAutoObject, IMyComObj)
  private
    FTotal: Integer;
    FList: TList;
  protected
    procedure Append(AValue: Integer); safecall;
    procedure RegisterObserver(AHandle: Integer); safecall;
    procedure UnRegisterObserver(AHandle: Integer); safecall;
  public
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
  end;

  TMyFactory = class(TAutoObjectFactory)
  public
    function CreateComObject(const Controller: IUnknown): TComObject; override;
  end;

implementation

uses ComServ, Windows, Messages, SrvFrmU;

var
  Instance: TMyComObj = nil;

procedure TMyComObj.AfterConstruction;
begin
     inherited;
     FTotal:=0;
     FList:=TList.Create;
end;

procedure TMyComObj.Append(AValue: Integer);
var wnd, I: Integer;
begin
     FTotal:=FTotal + AValue;
     for I:=FList.Count-1 downto 0 do
     begin
       wnd:=Integer(FList.Items[I]);
       if IsWindow(wnd) then
          PostMessage(wnd, WM_APP + 1, AValue, FTotal)
       else
          UnRegisterObserver(wnd); // unregister nonexistant observers
     end;
end;

procedure TMyComObj.BeforeDestruction;
begin
     FList.Free;
     inherited;
end;

procedure TMyComObj.RegisterObserver(AHandle: Integer);
begin
     if FList.IndexOf(Pointer(AHandle)) = -1 then
     begin
       FList.Add(Pointer(AHandle));
       SrvFrm.ObserverRegistered;
     end;
end;

procedure TMyComObj.UnRegisterObserver(AHandle: Integer);
begin
     if FList.Remove(Pointer(AHandle)) > -1 then
        SrvFrm.ObserverUnRegistered;
end;

{ TMyFactory }

function TMyFactory.CreateComObject(
  const Controller: IInterface): TComObject;
begin
     if not Assigned(Instance) then
        Instance:=TMyComObj(inherited CreateComObject(Controller));

     Result:=Instance;
end;

initialization
  TMyFactory.Create(ComServer, TMyComObj, Class_MyComObj,
    ciMultiInstance, tmSingle);
end.
0

Featured Post

Better Security Awareness With Threat Intelligence

See how one of the leading financial services organizations uses Recorded Future as part of a holistic threat intelligence program to promote security awareness and proactively and efficiently identify threats.

Join & Write a Comment

Suggested Solutions

A lot of questions regard threads in Delphi.   One of the more specific questions is how to show progress of the thread.   Updating a progressbar from inside a thread is a mistake. A solution to this would be to send a synchronized message to the…
In my programming career I have only very rarely run into situations where operator overloading would be of any use in my work.  Normally those situations involved math with either overly large numbers (hundreds of thousands of digits or accuracy re…
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …
This video demonstrates how to create an example email signature rule for a department in a company using CodeTwo Exchange Rules. The signature will be inserted beneath users' latest emails in conversations and will be displayed in users' Sent Items…

708 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now