Как можно работать с DDE?

Материал из DRKB


Как можно работать с DDE под Delphi, используя вызовы API

Кстати, достаточно легко: следующий пример демонстрирует как можно научить общаться клиентскую программу с программой-сервером. Обе программы полностью созданы на Delphi. В итоге мы имеет 2 проекта, 3 формы и 3 модуля. Для работы с DDE-запросами данный пример использует методы DDE ML API.

Сервер должен начать свою работу перед тем, как клиент будет загружен. Данный пример демонстрирует 3 способа взаимодействия между клиентом и сервером:

  • Клиент может "пропихивать" (POKE) данные на сервер.
  • Сервер может автоматически передавать данные клиенту, после чего клиент обновляет свой вид на основе результатов, полученных от сервера.
  • Данные сервера изменяются, после чего клиент делает запрос серверу для получения новых данных и обновляет свой вид.

Как работает программа.

DDEMLCLI.DPR[править | править код]

program Ddemlcli;

uses
  Forms,
  Ddemlclu in 'DDEMLCLU.PAS' {Form1};

{$R *.RES}

begin
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.


DDEMLCLU.DFM[править | править код]

object Form1: TForm1
  Left = 197
    Top = 95
    Width = 413
    Height = 287
    HorzScrollBar.Visible = False
    VertScrollBar.Visible = False
    Caption = 'Демонстрация DDEML, Клиентское приложение'
    Font.Color = clWindowText
    Font.Height = -13
    Font.Name = 'System'
    Font.Style = []
    Menu = MainMenu1
    PixelsPerInch = 96
    OnCreate = FormCreate
    OnDestroy = FormDestroy
    OnShow = FormShow
    TextHeight = 16
    object PaintBox1: TPaintBox
    Left = 0
      Top = 0
      Width = 405
      Height = 241
      Align = alClient
      Color = clWhite
      ParentColor = False
      OnPaint = PaintBox1Paint
  end
  object MainMenu1: TMainMenu
    Top = 208
      object File1: TMenuItem
      Caption = '&Файл'
        object exit1: TMenuItem
        Caption = 'В&ыход'
          OnClick = exit1Click
      end
    end
    object DDE1: TMenuItem
      Caption = '&DDE'
        object RequestUpdate1: TMenuItem
        Caption = '&Запрос на обновление'
          OnClick = RequestUpdate1Click
      end
      object AdviseofChanges1: TMenuItem
        Caption = '&Сообщение об изменениях'
          OnClick = AdviseofChanges1Click
      end
      object N1: TMenuItem
        Caption = '-'
      end
      object PokeSomeData: TMenuItem
        Caption = '&Пропихивание данных'
          OnClick = PokeSomeDataClick
      end
    end
  end
end


DDEMLCLU.PAS[править | править код]

{***************************************************}
{                                                   }
{   Delphi 1.0 DDEML Демонстрационная программа     }
{   Copyright (c) 1996 by Borland International     }
{                                                   }
{***************************************************}

{ Это демонстрационное приложение, демонстрирующее использование
DDEML API в клиентском приложении. Оно использует серверное
приложение DataEntry, которое является частью данной демонстрации,
и служит для ввода данных и отображения их на графической панели.

Сначала вы должны запустить приложение-сервер (в DDEMLSRV.PAS),
а затем стартовать клиента. Если сервер не запущен, клиент при
попытке соединения потерпит неудачу.

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

unit Ddemlclu;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, VBXCtrl, ExtCtrls, DDEML, Menus, StdCtrls;

const
  NumValues = 3;

type
  { Структура данных, представленная в примере }
  TDataSample = array[1..NumValues] of Integer;
  TDataString = array[0..20] of Char; { Размер элемента как текста }

  { Главная форма }
  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    exit1: TMenuItem;
    DDE1: TMenuItem;
    RequestUpdate1: TMenuItem;
    AdviseofChanges1: TMenuItem;
    PokeSomeData: TMenuItem;
    N1: TMenuItem;
    PaintBox1: TPaintBox;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure RequestUpdate1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure AdviseofChanges1Click(Sender: TObject);
    procedure PokeSomeDataClick(Sender: TObject);
    procedure Request(HConversation: HConv);
    procedure exit1Click(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
  private
    { Private declarations }
  public
    Inst: Longint;
    CallBackPtr: ^TCallback;
    ServiceHSz: HSz;
    TopicHSz: HSz;
    ItemHSz: array[1..NumValues] of HSz;
    ConvHdl: HConv;
    DataSample: TDataSample;
  end;

var
  Form1: TForm1;

implementation

const
  DataEntryName: PChar = 'DataEntry';
  DataTopicName: PChar = 'SampledData';
  DataItemNames: array[1..NumValues] of pChar = ('DataItem1',
    'DataItem2',
    'DataItem3');

{$R *.DFM}

{ Локальная функция: Процедура обратного вызова для DDEML }
function CallbackProc(CallType, Fmt: Word; Conv: HConv; hsz1, hsz2: HSZ;
  Data: HDDEData; Data1, Data2: Longint): HDDEData; export;
begin
  CallbackProc := 0; { В противном случае смотрите доказательство }

  case CallType of
    xtyp_Register:
      begin
        { Ничего ... Просто возвращаем 0 }
      end;
    xtyp_Unregister:
      begin
        { Ничего ... Просто возвращаем 0 }
      end;
    xtyp_xAct_Complete:
      begin
        { Ничего ... Просто возвращаем 0 }
      end;
    xtyp_Request, Xtyp_AdvData:
      begin
        Form1.Request(Conv);
        CallbackProc := dde_FAck;
      end;
    xtyp_Disconnect:
      begin
        ShowMessage('Соединение разорвано!');
        Form1.Close;
      end;
  end;
end;

{ Посылка DDE запроса для получения cf_Text данных с сервера.
  Запрашиваем данные для всех полей DataSample, и обновляем
  окно для их отображения. Данные с сервера получаем синхронно,
  используя DdeClientTransaction.}
  procedure TForm1.Request(HConversation: HConv);
var
  hDdeTemp: HDDEData;
  DataStr: TDataString;
  Err, I: Integer;
begin
  if HConversation <> 0 then
  begin
    for I := Low(ItemHSz) to High(ItemHSz) do
    begin
      hDdeTemp := DdeClientTransaction(nil, 0, HConversation, ItemHSz[I],
        cf_Text, xtyp_Request, 0, nil);
      if hDdeTemp <> 0 then
      begin
        DdeGetData(hDdeTemp, @DataStr, SizeOf(DataStr), 0);
        Val(DataStr, DataSample[I], Err);
      end; { if }
    end; { for }
    Paintbox1.Refresh; { Обновляем экран }
  end; { if }
end;

{ Создаем экземпляр окна DDE-клиента. Создаем окно, используя
  унаследованный конструктор, инициализируем экземпляр данных.}
procedure TForm1.FormCreate(Sender: TObject);
var
  I: Integer;
begin
  Inst := 0; { Должен быть нулем для первого вызова DdeInitialize }
  CallBackPtr := nil; { MakeProcInstance вызывается из SetupWindow    }
  ConvHdl := 0;
  ServiceHSz := 0;
  TopicHSz := 0;
  for I := Low(DataSample) to High(DataSample) do
  begin
    ItemHSz[I] := 0;
    DataSample[I] := 0;
  end;
end;

{ Уничтожаем экземпляр клиентского окна. Освобождаем дескрипторы
  DDE строк, и освобождаем экземпляр функции обратного вызова,
  если она существует. Также, для завершения диалога, вызовите
  DdeUninitialize. Затем, для завершения работы, вызовите
  разрушителя предка. }
procedure TForm1.FormDestroy(Sender: TObject);
var
  I: Integer;
begin
  if ServiceHSz <> 0 then
    DdeFreeStringHandle(Inst, ServiceHSz);
  if TopicHSz <> 0 then
    DdeFreeStringHandle(Inst, TopicHSz);
  for I := Low(ItemHSz) to High(ItemHSz) do
    if ItemHSz[I] <> 0 then
      DdeFreeStringHandle(Inst, ItemHSz[I]);

  if Inst <> 0 then
    DdeUninitialize(Inst); { Игнорируем возвращаемое значение }

  if CallBackPtr <> nil then
    FreeProcInstance(CallBackPtr);
end;

procedure TForm1.RequestUpdate1Click(Sender: TObject);
begin
  { Генерируем запрос DDE в ответ на выбор пункта меню DDE | Request.}
  Request(ConvHdl);
end;

{ Завершаем инициализацию окна сервера DDE. Выполняем те действия,
  которые требует правильное окно. Инициализируем использование DDEML. }
procedure TForm1.FormShow(Sender: TObject);
var
  I: Integer;
  InitOK: Boolean;
begin
  CallBackPtr := MakeProcInstance(@CallBackProc, HInstance);

  { Инициализируем DDE и устанавливаем функцию обратного вызова.
  Если сервер отсутствует, вызов терпит неудачу. }

  if CallBackPtr <> nil then
  begin
    if DdeInitialize(Inst, TCallback(CallBackPtr), AppCmd_ClientOnly, 0) = dmlErr_No_Error then
    begin
      ServiceHSz := DdeCreateStringHandle(Inst, DataEntryName, cp_WinAnsi);
      TopicHSz := DdeCreateStringHandle(Inst, DataTopicName, cp_WinAnsi);
      InitOK := True;
      {     for I := Low(DataItemNames) to High(DataItemNames) do begin }

      for I := 1 to NumValues do
      begin
        ItemHSz[I] := DdeCreateStringHandle(Inst, DataItemNames[I], cp_WinAnsi);
        InitOK := InitOK and (ItemHSz[I] <> 0);
      end;

      if (ServiceHSz <> 0) and (TopicHSz <> 0) and InitOK then
      begin
        ConvHdl := DdeConnect(Inst, ServiceHSz, TopicHSz, nil);
        if ConvHdl = 0 then
        begin
          ShowMessage('Не могу инициализировать диалог!');
          Close;
        end
      end
      else
      begin
        ShowMessage('Не могу создать строки!');
        Close;
      end
    end
    else
    begin
      ShowMessage('Не могу осуществить инициализацию!');
      Close;
    end;
  end;
end;

{ Переключаемся на режим DDE Advise с помощью пункта меню DDE |
  Advise (уведомление). При выборе этого пункта меню все три
  элемента переключаются на уведомление. }
procedure TForm1.AdviseofChanges1Click(Sender: TObject);
var
  I: Integer;
  TransType: Word;
  TempResult: Longint;
begin
  with TMenuITem(Sender) do
  begin
    Checked := not Checked;
    if Checked then
      TransType := (xtyp_AdvStart or xtypf_AckReq)
    else
      TransType := xtyp_AdvStop;
  end; { with }

  for I := Low(ItemHSz) to High(ItemHSz) do
    if DdeClientTransaction(nil, 0, ConvHdl, ItemHSz[I], cf_Text,
      TransType, 1000, @TempResult) = 0 then
      ShowMessage('Не могу выполнить транзакцию-уведомление');

  if TransType and xtyp_AdvStart <> 0 then
    Request(ConvHdl);
end;

{ Генерируем DDE-Poke транзакцию в ответ на выбор пункта
  меню DDE | Poke. Запрашиваем значение у пользователя,
  которое будем "проталкивать" в DataItem1 в качестве
  иллюстрации Poke-функции.}
procedure TForm1.PokeSomeDataClick(Sender: TObject);
var
  DataStr: pChar;
  S: string;
begin
  S := '0';
  if InputQuery('PokeData', 'Задайте проталкиваемую (Poke) величину', S) then
  begin
    S := S + #0;
    DataStr := @S[1];
    DdeClientTransaction(DataStr, StrLen(DataStr) + 1, ConvHdl,
      ItemHSz[1], cf_Text, xtyp_Poke, 1000, nil);
    Request(ConvHdl);
  end;
end;

procedure TForm1.exit1Click(Sender: TObject);
begin
  close;
end;

{ После запроса обновляем окно. Рисуем график объема текущих продаж.}
procedure TForm1.PaintBox1Paint(Sender: TObject);
const
  LMarg = 30; { Левое поле графика }
var
  I, Norm: Integer;
  Wd: Integer;
  Step: Integer;
  ARect: TRect;
begin
  Norm := 0;
  for I := Low(DataSample) to High(DataSample) do
  begin
    if abs(DataSample[I]) > Norm then
      Norm := abs(DataSample[I]);
  end; { for }

  if Norm = 0 then
    Norm := 1; { В случае если у нас все нули }

  with TPaintBox(Sender).Canvas do
  begin
    { Рисуем задний фон }
    Brush.color := clWhite;
    FillRect(ClipRect);

    { Рисуем ось }
    MoveTo(0, ClipRect.Bottom div 2);
    LineTo(ClipRect.Right, ClipRect.Bottom div 2);

    MoveTo(LMarg, 0);
    LineTo(LMarg, ClipRect.Bottom);

    { Печатаем текст левого поля }
    TextOut(0, 0, IntToStr(Norm));
    TextOut(0, ClipRect.Bottom div 2, '0');
    TextOut(0, ClipRect.Bottom + Font.Height, IntToStr(-Norm));

    TextOut(0, ClipRect.Bottom div 2, '0');
    TextOut(0, ClipRect.Bottom div 2, '0');
    TextOut(0, ClipRect.Bottom div 2, '0');
    { Печатаем текст оси X }

    { Теперь рисуем бары на основе нормализованного значения.
    Вычисляем ширину баров (чтобы они все вместились в окне)
    и ширину пробела между ними, который приблизительно равен
    20% от их ширины. }

    {
    SelectObject(PaintDC, CreateSolidBrush(RGB(255, 0, 0)));
    SetBkMode(PaintDC, Transparent);
    }

    ARect := ClipRect;
    Wd := (ARect.Right - LMarg) div NumValues;
    Step := Wd div 5;
    Wd := Wd - Step;
    with ARect do
    begin
      Left := LMarg + (Step div 2);
      Top := ClipRect.Bottom div 2;
    end; { with }

    { Выводим бары и текст для оси X }
    for i := Low(DataSample) to High(DataSample) do
    begin
      with ARect do
      begin
        Right := Left + Wd;
        Bottom := Top - Round((Top - 5) * (DataSample[I] / Norm));
      end; { with }
      { Заполняем бар }
      Brush.color := clFuchsia;
      FillRect(ARect);
      { Выводим текст для горизонтальной оси }
      Brush.color := clWhite;
      TextOut(ARect.Left, ClipRect.Bottom div 2 - Font.Height,
        StrPas(DataItemNames[i]));
      with ARect do
        Left := Left + Wd + Step;
    end; { for }
  end; { with }
end;
end.


DDEMLSVR.DPR[править | править код]

program Ddemlsvr;

uses
  Forms,
  Ddesvru in 'DDESVRU.PAS' {Form1},
  Ddedlg in '\DELPHI\BIN\DDEDLG.PAS' {DataEntry};

{$R *.RES}

begin
  Application.CreateForm(TForm1, Form1);
  Application.CreateForm(TDataEntry, DataEntry);
  Application.Run;
end.


DDESVRU.DFM[править | править код]

object Form1: TForm1
  Left = 712
  Top = 98
  Width = 307
  Height = 162
  Caption = 'Демонстрация DDEML, Серверное приложение'
  Color = clWhite
  Font.Color = clWindowText
  Font.Height = -13
  Font.Name = 'System'
  Font.Style = []
  Menu = MainMenu1
  PixelsPerInch = 96
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  OnShow = FormShow
  TextHeight = 16
  object Label1: TLabel
    Left = 0
    Top = 0
    Width = 99
    Height = 16
    Caption = 'Текущие значения:'
  end
  object Label2: TLabel
    Left = 16
    Top = 24
    Width = 74
    Height = 16
    Caption = 'Data Item1:'
  end
  object Label3: TLabel
    Left = 16
    Top = 40
    Width = 74
    Height = 16
    Caption = 'Data Item2:'
  end
  object Label4: TLabel
    Left = 16
    Top = 56
    Width = 74
    Height = 16
    Caption = 'Data Item3:'
  end
  object Label5: TLabel
    Left = 0
    Top = 88
    Width = 265
    Height = 16
    Caption = 'Выбор данных | Ввод данных для изменения значений.'
  end
  object Label6: TLabel
    Left = 96
    Top = 24
    Width = 8
    Height = 16
    Caption = '0'
  end
  object Label7: TLabel
    Left = 96
    Top = 40
    Width = 8
    Height = 16
    Caption = '0'
  end
  object Label8: TLabel
    Left = 96
    Top = 56
    Width = 8
    Height = 16
    Caption = '0'
  end
  object MainMenu1: TMainMenu
    Left = 352
    Top = 24
    object File1: TMenuItem
      Caption = '&Файл'
      object Exit1: TMenuItem
        Caption = '&Выход'
        OnClick = Exit1Click
      end
    end
    object Data1: TMenuItem
      Caption = '&Данные'
      object EnterData1: TMenuItem
        Caption = '&Ввод данных'
        OnClick = EnterData1Click
      end
      object Clear1: TMenuItem
        Caption = '&Очистить'
        OnClick = Clear1Click
      end
    end
  end
end


DDESVRU.PAS[править | править код]

{***************************************************}
{                                                   }
{   Delphi 1.0 DDEML Демонстрационная программа     }
{   Copyright (c) 1996 by Borland International     }
{                                                   }
{***************************************************}

{ Данный демонстрационный пример использует библиотеку DDEML
на стороне сервера кооперативного приложения. Данный сервер
является простым приложением для ввода данных и позволяет
оператору осуществлять ввод трех элементов данных, которые
становятся доступными через DDE "заинтересованным" клиентам.

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

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;
var
  DataStr: TDataString;
  Err: Integer;
  TempSample: Integer;
begin
  if (DdeCmpStringHandles(Item, ItemHSz[1]) = 0) and
    (ClipFmt = cf_Text) then
  begin
    DdeGetData(Data, @DataStr, SizeOf(DataStr), 0);
    Val(DataStr, TempSample, Err);

    if IntToStr(TempSample) <> Label6.Caption then
    begin
      Label6.Caption := IntToStr(TempSample);
      DataSample[1] := TempSample;
      if Advising[1] then
        DdePostAdvise(Inst, TopicHSz, ItemHSz[1]);
    end;
    AcceptPoke := True;
  end
  else
    AcceptPoke := False;
end;

{ Возвращаем данные, запрашиваемые значениями TransType
  и ClipFmt. Такое может произойти в ответ на просьбу
  xtyp_Request или xtyp_AdvReq. Параметр ItemNum указывает
  на поддерживаемый (в диапазоне 1..NumValues) и требуемый
  элемент (обратите внимание на то, что данный метод
  подразумевает, что вызывающий оператор уже установил
  достоверность и ID требуемого пункта с помощью
  MatchTopicAndItem). Соответствующие данные из переменной
  экземпляра DataSample преобразуются в текст и возвращаются
  клиенту.}
function TForm1.DataRequested(TransType: Word; ItemNum: Integer;
  ClipFmt: Word): HDDEData;
var
  ItemStr: TDataString; { Определено в DataEntry.TPU }
begin
  if ClipFmt = cf_Text then
  begin
    Str(DataSample[ItemNum], ItemStr);
    DataRequested := DdeCreateDataHandle(Inst, @ItemStr,
      StrLen(ItemStr) + 1, 0, ItemHSz[ItemNum], ClipFmt, 0);
  end
  else
    DataRequested := 0;
end;

{ Создаем экземпляр окна DDE сервера. Вызываем унаследованный
  конструктор, затем устанавливаем эти объекты родителями
  экземпляров данных. }
procedure TForm1.FormCreate(Sender: TObject);
var
  I: Integer;
begin
  Inst := 0; { Должен быть нулем для первого вызова DdeInitialize }
  @CallBack := nil; { MakeProcInstance вызывается из SetupWindow         }

  for I := 1 to NumValues do
  begin
    DataSample[I] := 0;
    Advising[I] := False;
  end; { for }
end;

{ Разрушаем экземпляр окна DDE сервера. Проверяем, был ли
  создан экземпляр процедуры обратного вызова, если он существует.
  Также, для завершения диалога, вызовите DdeUninitialize.
  Затем, для завершения работы, вызовите разрушителя предка.}
procedure TForm1.FormDestroy(Sender: TObject);
var
  I: Integer;
begin
  if ServiceHSz <> 0 then
    DdeFreeStringHandle(Inst, ServiceHSz);
  if TopicHSz <> 0 then
    DdeFreeStringHandle(Inst, TopicHSz);
  for I := 1 to NumValues do
    if ItemHSz[I] <> 0 then
      DdeFreeStringHandle(Inst, ItemHSz[I]);

  if Inst <> 0 then
    DdeUninitialize(Inst); { Игнорируем возвращаемое значение }

  if @CallBack <> nil then
    FreeProcInstance(@CallBack);
end;

{ Завершаем инициализацию окна DDE сервера. Процедура инициализации
  использует DDEML для регистрации сервисов, предусмотренных данным
  приложением. Помните о том, что реальные имена, использованные в
  регистрах, определены в отдельном модуле (DataEntry), поэтому они
  могут быть использованы и клиентом. }
procedure TForm1.FormShow(Sender: TObject);
var
  I: Integer;
begin
  @CallBack := MakeProcInstance(@CallBackProc, HInstance);

  if DdeInitialize(Inst, CallBack, 0, 0) = dmlErr_No_Error then
  begin
    ServiceHSz := DdeCreateStringHandle(Inst, DataEntryName, cp_WinAnsi);
    TopicHSz := DdeCreateStringHandle(Inst, DataTopicName, cp_WinAnsi);
    for I := 1 to NumValues do
      ItemHSz[I] := DdeCreateStringHandle(Inst, DataItemNames[I],
        cp_WinAnsi);

    if DdeNameService(Inst, ServiceHSz, 0, dns_Register) = 0 then
      ShowMessage('Ошибка в процессе регистрации.');
  end;
end;

{ Активизируем диалог ввода данных и обновляем
  хранимые данные по окончании ввода.}
procedure TForm1.EnterData1Click(Sender: TObject);
var
  I: Integer;
begin
  if DataEntry.ShowModal = mrOk then
  begin
    with DataEntry do
    begin
      Label6.Caption := S1;
      Label7.Caption := S2;
      Label8.Caption := S3;
      DataSample[1] := StrToInt(S1);
      DataSample[2] := StrToInt(S2);
      DataSample[3] := StrToInt(S3);
    end; { with }

    for I := 1 to NumValues do
      if Advising[I] then
        DdePostAdvise(Inst, TopicHSz, ItemHSz[I]);
  end; { if }
end;

{ Очищаем текущую дату. }
procedure TForm1.Clear1Click(Sender: TObject);
var
  I: Integer;
begin
  for I := 1 to NumValues do
  begin
    DataSample[I] := 0;
    if Advising[I] then
      DdePostAdvise(Inst, TopicHSz, ItemHSz[I]);
  end;

  Label6.Caption := '0';
  Label7.Caption := '0';
  Label8.Caption := '0';
end;

end.


DDEDLG.DFM[править | править код]

object DataEntry: TDataEntry
  Left = 488
    Top = 132
    ActiveControl = OKBtn
    BorderStyle = bsDialog
    Caption = 'Ввод данных'
    ClientHeight = 264
    ClientWidth = 199
    Font.Color = clBlack
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = [fsBold]
    PixelsPerInch = 96
    Position = poScreenCenter
    OnShow = FormShow
    TextHeight = 13
    object Bevel1: TBevel
    Left = 8
      Top = 8
      Width = 177
      Height = 201
      Shape = bsFrame
      IsControl = True
  end
  object OKBtn: TBitBtn
    Left = 16
      Top = 216
      Width = 69
      Height = 39
      Caption = '&OK'
      ModalResult = 1
      TabOrder = 3
      OnClick = OKBtnClick
      Glyph.Data = {
    BE060000424DBE06000000000000360400002800000024000000120000000100
    0800000000008802000000000000000000000000000000000000000000000000
    80000080000000808000800000008000800080800000C0C0C000C0DCC000F0CA
    A600000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    000000000000000000000000000000000000F0FBFF00A4A0A000808080000000
    FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00030303030303
    0303030303030303030303030303030303030303030303030303030303030303
    03030303030303030303030303030303030303030303FF030303030303030303
    03030303030303040403030303030303030303030303030303F8F8FF03030303
    03030303030303030303040202040303030303030303030303030303F80303F8
    FF030303030303030303030303040202020204030303030303030303030303F8
    03030303F8FF0303030303030303030304020202020202040303030303030303
    0303F8030303030303F8FF030303030303030304020202FA0202020204030303
    0303030303F8FF0303F8FF030303F8FF03030303030303020202FA03FA020202
    040303030303030303F8FF03F803F8FF0303F8FF03030303030303FA02FA0303
    03FA0202020403030303030303F8FFF8030303F8FF0303F8FF03030303030303
    FA0303030303FA0202020403030303030303F80303030303F8FF0303F8FF0303
    0303030303030303030303FA0202020403030303030303030303030303F8FF03
    03F8FF03030303030303030303030303FA020202040303030303030303030303
    0303F8FF0303F8FF03030303030303030303030303FA02020204030303030303
    03030303030303F8FF0303F8FF03030303030303030303030303FA0202020403
    030303030303030303030303F8FF0303F8FF03030303030303030303030303FA
    0202040303030303030303030303030303F8FF03F8FF03030303030303030303
    03030303FA0202030303030303030303030303030303F8FFF803030303030303
    030303030303030303FA0303030303030303030303030303030303F803030303
    0303030303030303030303030303030303030303030303030303030303030303
    0303}
    Margin = 2
    NumGlyphs = 2
    Spacing = -1
    IsControl = True
  end
  object CancelBtn: TBitBtn
    Left = 108
    Top = 216
    Width = 69
    Height = 39
    Caption = '&Отмена'
    TabOrder = 4
    Kind = bkCancel
    Margin = 2
    Spacing = -1
    IsControl = True
  end
  object Panel2: TPanel
    Left = 16
    Top = 88
    Width = 153
    Height = 49
    BevelInner = bvLowered
    BevelOuter = bvNone
    TabOrder = 1
    object Label1: TLabel
      Left = 24
      Top = 8
      Width = 5
      Height = 13
    end
    object Label2: TLabel
      Left = 8
      Top = 8
      Width = 48
      Height = 13
      Caption = 'Значение 2:'
    end
    object Edit2: TEdit
      Left = 8
      Top = 24
      Width = 121
      Height = 20
      MaxLength = 10
      TabOrder = 0
      Text = '0'
    end
  end
  object Panel1: TPanel
    Left = 16
    Top = 16
    Width = 153
    Height = 49
    BevelInner = bvLowered
    BevelOuter = bvNone
    TabOrder = 0
    object Label4: TLabel
      Left = 8
      Top = 8
      Width = 48
      Height = 13
      Caption = 'Значение 1:'
    end
    object Edit1: TEdit
      Left = 8
      Top = 24
      Width = 121
      Height = 20
      MaxLength = 10
      TabOrder = 0
      Text = '0'
    end
  end
  object Panel3: TPanel
    Left = 16
    Top = 144
    Width = 153
    Height = 49
    BevelInner = bvLowered
    BevelOuter = bvNone
    TabOrder = 2
    object Label6: TLabel
      Left = 8
      Top = 8
      Width = 48
      Height = 13
      Caption = 'Значение 3:'
    end
    object Edit3: TEdit
      Left = 8
      Top = 24
      Width = 121
      Height = 20
      MaxLength = 10
      TabOrder = 0
      Text = '0'
    end
  end
end


DDEDLG.PAS[править | править код]

{***************************************************}
{                                                   }
{   Delphi 1.0 DDEML Демонстрационная программа     }
{   Copyright (c) 1996 by Borland International     }
{                                                   }
{***************************************************}

{ Данный модуль определяет интерфейс сервера DataEntry DDE

(DDEMLSRV.PAS). Здесь определены имена Service, Topic,
и Item, поддерживаемые сервером, и также определена
структура данных, которая может использоваться
клиентом для локального хранения "показательных" данных.

Сервер Data Entry Server делает свои "показательные"
данные доступными в текстовом виде (cf_Text)
сформированными в виде трех различных топика (Topics).
Клиент может их преобразовывать в целое для
использования со структурой данных, которая здесь определена.
}
unit Ddedlg;

interface

uses WinTypes, WinProcs, Classes, Graphics, Forms, Controls, Buttons,
  StdCtrls, Mask, ExtCtrls;

type
  TDataEntry = class(TForm)
    OKBtn: TBitBtn;
    CancelBtn: TBitBtn;
    Bevel1: TBevel;
    Panel2: TPanel;
    Label1: TLabel;
    Label2: TLabel;
    Panel1: TPanel;
    Label4: TLabel;
    Panel3: TPanel;
    Label6: TLabel;
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    procedure OKBtnClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
  public
    S1, S2, S3: string;
    { Public declarations }
  end;

var
  DataEntry: TDataEntry;

implementation

{$R *.DFM}

procedure TDataEntry.OKBtnClick(Sender: TObject);
begin
  S1 := Edit1.Text;
  S2 := Edit2.Text;
  S3 := Edit3.Text;
end;

procedure TDataEntry.FormShow(Sender: TObject);
begin
  Edit1.Text := '0';
  Edit2.Text := '0';
  Edit3.Text := '0';
  Edit1.SetFocus;
end;

end.


Source: http://delphiworld.narod.ru
ID: 04493
ID: 04502