OLE клиент-сервер

Delphi , Технологии , OLE

Автор: Xavier Pacheco

unit CliMain;

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.

unit ServAuto;

interface

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.

Программный проект на языке Delphi, реализующий архитектуру клиент-сервер с использованием технологии OLE (Object Linking and Embedding) и компонентов COM (Component Object Model) и ActiveX.

Проект состоит из двух основных частей:

1. Клиентская часть: модуль CliMain содержит основную форму (TMainForm) для взаимодействия с сервером. Форма имеет несколько кнопок (Send, Clear, Close) и текстовый поле (Edit) для ввода текста.
2. Серверная часть: модуль ServAuto реализует серверную сторону приложения с использованием технологии COM и ActiveX. Он определяет класс (TServerWithEvents), который предоставляет методы для добавления текста, очистки мемо и обработки событий.

Общий обзор работы проекта:

1. Клиентская форма создает экземпляр серверной стороны объекта (TServerWithEvents) с помощью CoCreateInstance.
2. Клиентская форма настраивает соединения sink-эвентов с серверной стороной объекта для получения уведомлений о событиях, происходящих на серверной стороне (например, при добавлении или очистке текста).
3. Когда кнопка клиентской формы нажата, она отправляет запрос серверной стороне объекта для выполнения действия (например, добавить текст или очистить мемо). Серверная сторона объекта обрабатывает запрос и уведомляет клиентскую форму о любых изменениях.
4. Клиентская форма обновляет свой пользовательский интерфейс в соответствии с изменениями.

Некоторые заметные функции проекта:

• COM-based communication: Проект использует технологию COM и ActiveX для обеспечения взаимодействия между клиентской и серверной сторонами.
• Event-driven architecture: Серверная сторона объекта предоставляет уведомления о событиях клиентской форме, позволяя двустороннему общению и синхронизации данных.
• Dynamic creation of objects: Проект демонстрирует создание и управление COM-объектами динамически с помощью CoCreateInstance.

В целом, проект представляет собой основу OLE клиент-серверной архитектуры в Delphi с использованием технологии COM и ActiveX.

"Пример использования технологии OLE клиент-сервер для создания приложения с интерфейсом на Delphi".

Комментарии и вопросы

Получайте свежие новости и обновления по Object Pascal, Delphi и Lazarus прямо в свой смартфон. Подпишитесь на наш Telegram-канал delphi_kansoftware и будьте в курсе последних тенденций в разработке под Linux, Windows, Android и iOS

:: Главная :: OLE ::