Недавно добавленные исходники

•  TDictionary Custom Sort  505

•  Fast Watermark Sources  872

•  3D Designer  1 799

•  Sik Screen Capture  1 455

•  Patch Maker  1 459

•  Айболит (remote control)  1 387

•  ListBox Drag & Drop  1 154

•  Доска для игры Реверси  21 197

•  Графические эффекты  1 332

•  Рисование по маске  1 274

•  Перетаскивание изображений  1 084

•  Canvas Drawing  961

•  Рисование Луны  797

•  Поворот изображения  754

•  Рисование стержней  801

•  Paint on Shape  486

•  Генератор кроссвордов  747

•  Головоломка Paletto  659

•  Теорема Монжа об окружностях  839

•  Пазл Numbrix  606

•  Заборы и коммивояжеры  835

•  Игра HIP  549

•  Игра Go (Го)  522

•  Симулятор лифта  544

•  Программа укладки плитки  505

•  Генератор лабиринта  560

•  Проверка числового ввода  518

•  HEX View  595

•  Физический маятник  522

•  Задача коммивояжера  555

 
скрыть


Delphi FAQ - Часто задаваемые вопросы

| Базы данных | Графика и Игры | Интернет и Сети | Компоненты и Классы | Мультимедиа |
| ОС и Железо | Программа и Интерфейс | Рабочий стол | Синтаксис | Технологии | Файловая система |



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.
Скачать весь проект




Похожие по теме исходники

Win Console

Molecula (3D молекула)

Molecule (молекула)

Console FTP

 

CMD OLE

DeParole

Console SmartEngine

Close Console on Event

 

Console Task Manager

Stud WebServer (web-сервер)

Proxy 1.0 (прокси-сервер)




Copyright © 2004-2022 "Delphi Sources" by BrokenByte Software. Delphi World FAQ

Группа ВКонтакте   Facebook   Ссылка на Twitter   Ссылка на Telegram