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

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...

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...

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.

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. :-)

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 :)

Time isn't on my side either... :-)

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

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

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.

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.

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

ofcourse you can do one ...
create a descendant of TAutoObjectFactory that handles the singleton
.. will create an example shortly :)

the object singleton trick is a reference from: http://howtodothings.com/showarticle.asp?article=170 :)

Seems fine to me. :-)

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.