Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Как можно работать с DDE под Delphi, используя вызовы API

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

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

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

Ниже приведены 8 файлов, сконкатенированных в единое целое. Каждый файл имеет следующую структуру:
{ *** НАЧАЛО КОДА FILENAME.EXT *** } КОД { *** КОНЕЦ КОДА FILENAME.EXT *** },
поэтому вам остается всего-лишь взять код, расположенный между маркерами { *** }, скопировать в файл с соответствующим именем, и собрать оба проекта в среде Delphi


{ *** НАЧАЛО КОДА DDEMLCLI.DPR *** }
program Ddemlcli;

uses

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

{$R *.RES}

begin

  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.
{ ***  КОНЕЦ КОДА DDEMLCLI.DPR *** }

{ *** НАЧАЛО КОДА 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.DFM *** }

{ *** НАЧАЛО КОДА 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;

procedure TForm1.FormCreate(Sender: TObject);
var

  I: Integer;
  { Создаем экземпляр окна DDE-клиента. Создаем окно, используя
  унаследованный конструктор, инициализируем экземпляр данных.}
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;

procedure TForm1.FormDestroy(Sender: TObject);
{ Уничтожаем экземпляр клиентского окна. Освобождаем дескрипторы
DDE строк, и освобождаем экземпляр функции обратного вызова,
если она существует. Также, для завершения диалога, вызовите
DdeUninitialize. Затем, для завершения работы, вызовите
разрушителя предка. }
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;

procedure TForm1.FormShow(Sender: TObject);
{ Завершаем инициализацию окна сервера DDE. Выполняем те действия,
которые требует правильное окно. Инициализируем использование DDEML. }
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;

procedure TForm1.AdviseofChanges1Click(Sender: TObject);
{ Переключаемся на режим DDE Advise с помощью пункта меню DDE |
Advise (уведомление). При выборе этого пункта меню все три
элемента переключаются на уведомление. }
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;

procedure TForm1.PokeSomeDataClick(Sender: TObject);
{ Генерируем DDE-Poke транзакцию в ответ на выбор пункта
меню DDE | Poke. Запрашиваем значение у пользователя,
которое будем "проталкивать" в DataItem1 в качестве
иллюстрации Poke-функции.}
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. { ***  КОНЕЦ КОДА DDEMLCLU.PAS *** }

{ *** НАЧАЛО КОДА 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.
{ ***  КОНЕЦ КОДА DDEMLSVR.DPR *** }

{ *** НАЧАЛО КОДА 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.DFM *** }

{ *** НАЧАЛО КОДА 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;

procedure TForm1.FormShow(Sender: TObject);
var

  I: Integer;
  { Завершаем инициализацию окна DDE сервера. Процедура инициализации
  использует DDEML для регистрации сервисов, предусмотренных данным
  приложением. Помните о том, что реальные имена, использованные в
  регистрах, определены в отдельном модуле (DataEntry), поэтому они
  могут быть использованы и клиентом. }

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.
{ ***  КОНЕЦ КОДА DDESVRU.PAS *** }

{ *** НАЧАЛО КОДА 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.DFM *** }

{ *** НАЧАЛО КОДА 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.
{ ***  КОНЕЦ КОДА DDEDLG.PAS *** }

Проект Delphi World © Выпуск 2002 - 2004
Автор проекта: ___Nikolay