Валентин Озеров - Советы по Delphi. Версия 1.4.3 от 1.1.2001

• Название: Советы по Delphi. Версия 1.4.3 от 1.1.2001
• Автор: Валентин Озеров
• Жанр: Программирование

…начиная с 1001. Смотрите другие файлы…

---

Данный сервер предоставляет свои услуги (сервисы) для данных со следующими именами:

 Service: 'DataEntry'

 Topic  : 'SampledData'

 Items  : 'DataItem1', 'DataItem2', 'DataItem3'

В-принципе, в качестве сервисов могли бы быть определены и другие темы. Полезными темами, на наш взгляд, могут быть исторические даты, информация о сэмплах и пр..

Вы должны запустить этот сервер ПЕРЕД тем как запустите клиента (DDEMLCLI.PAS), в противном случае клиент не сможет установить связь.

Интерфейс для этого сервера определен как список имен (Service, Topic и Items) в отдельном модуле с именем DataEntry (DATAENTR.TPU). Сервер делает Items доступными в формате cf_Text; они преобразовываются и хранятся у клиента локально как целые. }

unit Ddesvru;

interface

uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Menus, DDEML, { DDE APi }ShellApi;

const

 NumValues = 3;

 DataItemNames : array [1..NumValues] of PChar = ('DataItem1', 'DataItem2', 'DataItem3');

type

 TDataString = array [0..20] of Char; { Размер элемента как текста }

 TDataSample = array [1..NumValues] of Integer;

{type

{ Структура данных, составляющих образец }

{  TDataSample = array [1..NumValues] of Integer;

{  TDataString = array [0..20] of Char;     { Размер элемента как текста }

const

 DataEntryName: PChar = 'DataEntry';

 DataTopicName: PChar = 'SampledData';

type TForm1 = class(TForm)

 MainMenu1: TMainMenu;

 File1: TMenuItem;

 Exit1: TMenuItem;

 Data1: TMenuItem;

 EnterData1: TMenuItem;

 Clear1: TMenuItem;

 Label1: TLabel;

 Label2: TLabel;

 Label3: TLabel;

 Label4: TLabel;

 Label5: TLabel;

 Label6: TLabel;

 Label7: TLabel;

 Label8: TLabel;

 procedure Exit1Click(Sender: TObject);

 function MatchTopicAndService(Topic, Service: HSz): Boolean;

 function MatchTopicAndItem(Topic, Item: HSz): Integer;

 function WildConnect(Topic, Service: HSz; ClipFmt: Word): HDDEData;

 function AcceptPoke(Item: HSz; ClipFmt: Word;Data: HDDEData): Boolean;

 function DataRequested(TransType: Word; ItemNum: Integer; ClipFmt: Word): HDDEData;

 procedure FormCreate(Sender: TObject);

 procedure FormDestroy(Sender: TObject);

 procedure FormShow(Sender: TObject);

 procedure EnterData1Click(Sender: TObject);

 procedure Clear1Click(Sender: TObject);

private

 Inst       : Longint;

 CallBack   : TCallback;

 ServiceHSz : HSz;

 TopicHSz   : HSz;

 ItemHSz    : array [1..NumValues] of HSz;

 ConvHdl    : HConv;

 Advising   : array [1..NumValues] of Boolean;

 DataSample : TDataSample;

public

 { Public declarations }

end;

var Form1: TForm1;

implementation

uses DDEDlg; { Форма DataEntry }

{$R *.DFM}

procedure TForm1.Exit1Click(Sender: TObject);

begin

 Close;

end;

{ Глобальная инициализация }

const

 DemoTitle: PChar = 'DDEML демо, серверное приложение';

 MaxAdvisories = 100;

 NumAdvLoops : Integer = 0;

{ Локальная функция: Процедура обратного вызова для DDEML }

{ Данная функция обратного вызова реагирует на все транзакции, генерируемые DDEML. Объект "target Window" (окно-цель) берется из глобально хранимых, и для реагирования на данную транзакцию, тип которой указан в параметре CallType, используются подходящие методы этих объектов.}

function CallbackProc(CallType, Fmt: Word; Conv: HConv; HSz1, HSz2: HSZ; Data: HDDEData; Data1, Data2: Longint): HDDEData; export;

var

 ItemNum: Integer;

begin

 CallbackProc := 0; { В противном случае смотрите доказательство }

 case CallType of

 xtyp_WildConnect:

  CallbackProc := Form1.WildConnect(HSz1, HSz2, Fmt);

 xtyp_Connect:

  if Conv = 0 then begin

   if Form1.MatchTopicAndService(HSz1, HSz2) then CallbackProc := 1; { Связь! }

  end;

  { После подтверждения установки соединения записываем дескриптор связи как родительское окно.}

 xtyp_Connect_Confirm:

  Form1.ConvHdl := Conv;

  { Клиент запрашивает данные, делает прямой запрос или отвечает на уведомление. Возвращаем текущее состояние данных.}

 xtyp_AdvReq, xtyp_Request:

  begin

   ItemNum := Form1.MatchTopicAndItem(HSz1, HSz2);

   if ItemNum > 0 then CallbackProc := Form1.DataRequested(CallType, ItemNum, Fmt);

  end;

  { Отвечаем на Poke-запрос ... данная демонстрация допускает только Pokes для DataItem1. Для подтверждения получения запроса возвращаем dde_FAck, в противном случае 0.}

 xtyp_Poke:

  begin

   if Form1.AcceptPoke(HSz2, Fmt, Data) then CallbackProc := dde_FAck;

  end;

  { Клиент сделал запрос для старта цикла-уведомления. Имейте в виду, что мы организуем "горячий" цикл. Устанавливаем флаг Advising для указания открытого цикла, который будет проверять данные на предмет их изменения.}

 xtyp_AdvStart:

  begin

   ItemNum := Form1.MatchTopicAndItem(HSz1, HSz2);

   if ItemNum > 0 then begin

    if NumAdvLoops < MaxAdvisories then begin

     { Произвольное число }

     Inc(NumAdvLoops);

     Form1.Advising[ItemNum] := True;

     CallbackProc := 1;

    end;

   end;

  end;

  { Клиент сделал запрос на прерывание цикла-уведомления.}

 xtyp_AdvStop:

  begin

   ItemNum := Form1.MatchTopicAndItem(HSz1, HSz2);

   if ItemNum > 0 then begin

    if NumAdvLoops > 0 then begin

     Dec(NumAdvLoops);

     if NumAdvLoops = 0 then Form1.Advising[ItemNum] := False;

     CallbackProc := 1;

    end;

   end;

  end;

 end; { Case CallType }

end;

{ Возращает True, если данные Topic и Service поддерживаются этим приложением. В противном случае возвращается False.}

function TForm1.MatchTopicAndService(Topic, Service: HSz): Boolean;

begin

 Result := False;

 if DdeCmpStringHandles(TopicHSz, Topic) = 0 then

  if DdeCmpStringHandles(ServiceHSz, Service) = 0 then Result := True;

end;

{ Определяем, один ли Topic и Item поддерживается этим приложением. Возвращаем номер заданного элемента (Item Number) (в пределах 1..NumValues), если он обнаружен, и ноль в противном случае.}

function TForm1.MatchTopicAndItem(Topic, Item: HSz): Integer;

var I : Integer;

begin

 Result := 0;

 if DdeCmpStringHandles(TopicHSz, Topic) = 0 then

  for I := 1 to NumValues do

   if DdeCmpStringHandles(ItemHSz[I], Item) = 0 then

    Result := I;

end;

{ Отвечаем на запрос wildcard-соединения (дословно - дикая карта, шаблон). Такие запросы возникают всякий раз, когда клиент пытается подключиться к серверу с сервисом или именем топика, установленного в 0. Если сервер обнаруживает использование такого рода шаблона, он возвращает дескриптор массива THSZPair, содержащего найденные по шаблону Service и Topic.}

function TForm1.WildConnect(Topic, Service: HSz; ClipFmt: Word): HDDEData;

var

 TempPairs: array [0..1] of THSZPair;

 Matched  : Boolean;

begin

 TempPairs[0].hszSvc:= ServiceHSz;

 TempPairs[0].hszTopic:= TopicHSz;

 TempPairs[1].hszSvc:= 0; { 0-завершает список }

 TempPairs[1].hszTopic:= 0;

 Matched := False;

 if (Topic= 0) and (Service = 0) then Matched := True { Шаблон обработан, элементов не найдено }

 else

  if (Topic = 0) and (DdeCmpStringHandles(Service, ServiceHSz) = 0) then Matched := True

  else if (DdeCmpStringHandles(Topic, TopicHSz) = 0) and (Service = 0) then Matched := True;

 if Matched then

  WildConnect := DdeCreateDataHandle(Inst, @TempPairs, SizeOf(TempPairs), 0, 0, ClipFmt, 0)

 else WildConnect := 0;

end;

{ Принимаем и проталкиваем данные по просьбе клиента. Для демонстрации этого способа используем только значение DataItem1, изменяемое Poke.}

function TForm1.AcceptPoke(Item: HSz; ClipFmt: Word; Data: HDDEData): Boolean;