Здравствуйте, George Seryakov.
Maxim Mednikov


Спасибо за ответ.

Суть проблемы в том, что при подключении и отключении сервера автоматизации происходит утечка памяти.
Т.е. при подключении и отключении клиента происходит увеличении размера внепроцессорного сервера автоматизации вплоть до переполнения виртуальной памяти.
Данные примеры не из моего проекта, а из книги Delphi 6 руководство разработчика Стив Тейксер. Подобные примеры можно найти в книге Delphi 6 и Com Елманова, А Тенцер.
В каждом примере утечка памяти сервера автоматизации. Могу их выслать по E-mail.

Если вы писали сервер автоматизации на Delphi 5-7, то не могли не заметить этого подводного камня.

Вот пример приложения.
Внепроцессорный сервер автоматизации:

unit ServAuto;
interface
{$WARN SYMBOL_PLATFORM OFF}
uses
ComObj, ActiveX, AxCtrls, Server_TLB;
type
TServerWithEvents = class(TAutoObject, IConnectionPointContainer, IServerWithEvents)
private
{ Private declarations }
FConnectionPoints: TConnectionPoints;
FEvents: IServerWithEventsEvents;
procedure MemoChange(Sender: TObject);
public
procedure Initialize; override;
protected
{ Protected declarations }
property ConnectionPoints: TConnectionPoints read FConnectionPoints
implements IConnectionPointContainer;
procedure EventSinkChanged(const EventSink: IUnknown); override;
procedure Clear; safecall;
procedure AddText(const NewText: WideString); safecall;
end;

implementation
uses ComServ, ServMain, SysUtils, StdCtrls;
procedure TServerWithEvents.EventSinkChanged(const EventSink: IUnknown);
begin
FEvents := EventSink as IServerWithEventsEvents;
end;
procedure TServerWithEvents.Initialize;
begin
inherited Initialize;
FConnectionPoints := TConnectionPoints.Create(Self);
if AutoFactory.EventTypeInfo <> nil then
FConnectionPoints.CreateConnectionPoint(AutoFactory.EventIID,
ckSingle, EventConnect);
// Route main form memo's OnChange event to MemoChange method:
MainForm.Memo.OnChange := MemoChange;
end;
procedure TServerWithEvents.Clear;
begin
MainForm.Memo.Lines.Clear;
if FEvents <> nil then FEvents.OnClear;
end;
procedure TServerWithEvents.AddText(const NewText: WideString);
begin
MainForm.Memo.Lines.Add(NewText);
end;
procedure TServerWithEvents.MemoChange(Sender: TObject);
begin
if FEvents <> nil then FEvents.OnTextChanged((Sender as TMemo).Text);
end;
initialization
TAutoObjectFactory.Create(ComServer, TServerWithEvents,
Class_ServerWithEvents, ciMultiInstance, tmApartment);
end.



Клиент:
На стороне клиента вызывать FormCreate и FormDestroy, которые подключаются и отключаются от сервера автоматизации.

unit CliMain;
{$WARN SYMBOL_PLATFORM OFF}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Server_TLB, ComObj;
type
TEventSink = class;
TMainForm = class(TForm)
SendButton: TButton;
CloseButton: TButton;
ClearButton: TButton;
Edit: TEdit;
Memo: TMemo;
procedure FormCreate(Sender: TObject);
procedure SendButtonClick(Sender: TObject);
procedure ClearButtonClick(Sender: TObject);
procedure CloseButtonClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
FServer: IServerWithEvents;
FEventSink: TEventSink;
FCookie: Integer;
procedure OnServerMemoChanged(const NewText: string);
procedure OnClear;
public
{ Public declarations }
end;

TEventSink = class(TObject, IUnknown, IDispatch)
private
FController: TMainForm;
{ IUnknown }
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
{ 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;
public
constructor Create(Controller: TMainForm);
end;

var
MainForm: TMainForm;

implementation
uses ActiveX;
{$R *.DFM}
{ TMainForm }
procedure TMainForm.FormCreate(Sender: TObject);
begin
FServer := CoServerWithEvents.Create;
FEventSink := TEventSink.Create(Self);
InterfaceConnect(FServer, IServerWithEventsEvents, FEventSink, FCookie);
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
InterfaceDisconnect(FEventSink, IServerWithEventsEvents, FCookie);
FEventSink.Free;
end;
procedure TMainForm.SendButtonClick(Sender: TObject);
begin
FServer.AddText(Edit.Text);
end;
procedure TMainForm.ClearButtonClick(Sender: TObject);
begin
FServer.Clear;
end;
procedure TMainForm.CloseButtonClick(Sender: TObject);
begin
Close;
end;
procedure TMainForm.OnServerMemoChanged(const NewText: string);
begin
Memo.Text := NewText;
end;
procedure TMainForm.OnClear;
begin
Memo.Clear;
end;
{ TEventSink }
constructor TEventSink.Create(Controller: TMainForm);
begin
FController := Controller;
inherited Create;
end;
{ TEventSink.IUnknown }

function TEventSink._AddRef: Integer;
begin
// No need to implement, since lifetime is tied to client
Result := 1;
end;
function TEventSink._Release: Integer;
begin
// No need to implement, since lifetime is tied to client
Result := 1;
end;
function TEventSink.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
// First look for my own implementation of an interface
// (I implement IUnknown and IDispatch).
if GetInterface(IID, Obj) then
Result := S_OK
// Next, if they are looking for outgoing interface, recurse to return
// our IDispatch pointer.
else if IsEqualIID(IID, IServerWithEventsEvents) then
Result := QueryInterface(IDispatch, Obj)
// For everything else, return an error.
else
Result := E_NOINTERFACE;
end;
{ TEventSink.IDispatch }
function TEventSink.GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
Result := E_NOTIMPL;
end;
function TEventSink.GetTypeInfo(Index, LocaleID: Integer;
out TypeInfo): HResult;
begin
Pointer(TypeInfo) := nil;
Result := E_NOTIMPL;
end;
function TEventSink.GetTypeInfoCount(out Count: Integer): HResult;
begin
Count := 0;
Result := S_OK;
end;
function TEventSink.Invoke(DispID: Integer; const IID: TGUID;
LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
ArgErr: Pointer): HResult;
var
V: OleVariant;
begin
Result := S_OK;
case DispID of
1:
begin
// First parameter is new string
V := OleVariant(TDispParams(Params).rgvarg^[0]);
FController.OnServerMemoChanged(V);
end;
2: FController.OnClear;
end;
end;
end.