Delphi World - Обмен информацией между программами в сети по почтовым каналам

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

Обмен информацией между программами в сети по почтовым каналам

Как реализовать обмен информацией между Вашими приложениями в сети? ОС Windows предлагает несколько технологий. Эта статья опишет один очень простой и надежный способ для Win9x/NT - MailSlots.

The CreateMailslot function creates a mailslot with the specified name and returns a handle that a mailslot server can use to perform operations on the mailslot. The mailslot is local to the computer that creates it. An error occurs if a mailslot with the specified name already exists.

Обмен текстовыми данными в локальной сети очень прост. Для этого необходимы функции:

CreateMailslot: создание почтового канала;
GetMailslotInfo: определение наличия сообщения в канале;
ReadFile: чтение сообщения из канала, как из файла;
WriteFile: запись сообщения в канал, как в файл;

Функции работы с почтовыми каналами присутствуют как в Windows 9x, так и в Windows NT.

Рассмотрим создание почтового канала (сервер).

//... создание канала с именем MailSlotName - по этому имени к нему
// будут обращаться клиенты
h := CreateMailSlot(PChar('\\.\mailslot\' + MailSlotName),
0, MAILSLOT_WAIT_FOREVER,nil);

if h = INVALID_HANDLE_VALUE then
begin
  raise Exception.Create('MailSlotServer: Ошибка создания канала !');

Отправка сообщений по почтовомуо каналу (клиенты).

if not GetMailSlotInfo(h,nil,DWORD(MsgNext),@MsgNumber,nil) then
begin
  raise Exception.Create('TglMailSlotServer: Ошибка сбора информации!');
end;

if MsgNext <> MAILSLOT_NO_MESSAGE then
begin
  beep;
  // чтение сообщения из канала и добавление в текст протокола
  if ReadFile(h,str,200,DWORD(read),nil) then
    MessageText := str
  else
    raise Exception.Create('TglMailSlotServer: Ошибка чтения сообщения !');
end;

Все очень просто. Теперь для удобства использования создадим два компонента - клиент и сервер

{
Globus Delphi VCL Extensions Library
' GLOBUS LIB '
Freeware
Copyright (c) 2000 Chudin A.V, FidoNet: 1246.1
gl3DCol Unit 05.2000 components TglMailSlotServer, TglMailSlotClient
}
unit glMSlots;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, extctrls;

type
  TOnNewMessage = procedure (Sender: TObject; MessageText: string) of object;

  TglMailSlotServer = class(TComponent)
  private
    FMailSlotName, FLastMessage: string;
    FOnNewMessage: TOnNewMessage;

    Timer: TTimer; //...таймер для прослушивания канала
    h : THandle;
    str : string[250];
    MsgNumber,MsgNext,read : DWORD;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Open; //...создание канала
    procedure Close; //...закрытие канала
  protected
    procedure Loaded; override;
    procedure OnTimer(Sender: TObject);
  published
    property MailSlotName: string read FMailSlotName write FMailSlotName;
    //...событие получения сообщения
    property OnNewMessage: TOnNewMessage read FOnNewMessage write FOnNewMessage;
  end;


  TglMailSlotClient = class(TComponent)
  private
    FMailSlotName, FServerName, FLastMessage: string;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Send(str: string):boolean; //...отправка сообщения
  protected
    procedure Loaded; override;
    procedure ErrorCatch(Sender : TObject; Exc : Exception);
  published
    property ServerName: string read FServerName write FServerName;
    property MailSlotName: string read FMailSlotName write FMailSlotName;
  end;

procedure register;

implementation

procedure register;
begin
  RegisterComponents('Gl Components', [TglMailSlotServer, TglMailSlotClient]);
end;

constructor TglMailSlotServer.Create(AOwner: TComponent);
begin
  inherited;
  FEnabled := true;
  FMailSlotName := 'MailSlot';
  Timer := TTimer.Create(nil);
  Timer.Enabled := false;
  Timer.OnTimer := OnTimer;
end;

destructor TglMailSlotServer.Destroy;
begin
  Timer.Free;
  // закрытие канала
  Close;
  inherited;
end;

procedure TglMailSlotServer.Loaded;
begin
  inherited;
  Open;
end;

procedure TglMailSlotServer.Open;
begin
  // создание канала с именем MailSlotName - по этому имени к нему
  // будут обращаться клиенты
  h := CreateMailSlot(PChar('\\.\mailslot\' + MailSlotName),
  0, MAILSLOT_WAIT_FOREVER,nil);
  //h:=CreateMailSlot('\\.\mailslot\MailSlot', 0, MAILSLOT_WAIT_FOREVER,nil);

  if h = INVALID_HANDLE_VALUE then
    raise Exception.Create('TglMailSlotServer: Ошибка создания канала !');
  Timer.Enabled := true;
end;

procedure TglMailSlotServer.Close;
begin
  if h <> 0 then
    CloseHandle(h);
  h := 0;
end;

procedure TglMailSlotServer.OnTimer(Sender: TObject);
var
  MessageText: string;
begin
  MessageText := '';
  // определение наличия сообщения в канале
  if not GetMailSlotInfo(h,nil,DWORD(MsgNext),@MsgNumber,nil) then
    raise Exception.Create('TglMailSlotServer: Ошибка сбора информации!');

  if MsgNext <> MAILSLOT_NO_MESSAGE then
  begin
    beep;
    // чтение сообщения из канала и добавление в текст протокола
    if ReadFile(h,str,200,DWORD(read),nil) then
      MessageText := str
    else
      raise Exception.Create('TglMailSlotServer: Ошибка чтения сообщения !');
  end;

  if (MessageText<>'')and Assigned(OnNewMessage) then
    OnNewMessage(self, MessageText);

  FLastMessage := MessageText;
end;

constructor TglMailSlotClient.Create(AOwner: TComponent);
begin
  inherited;
  FMailSlotName := 'MailSlot';
  FServerName := '';
end;

destructor TglMailSlotClient.Destroy;
begin
  inherited;
end;

procedure TglMailSlotClient.Loaded;
begin
  inherited;
  Application.OnException := ErrorCatch;
end;

procedure TglMailSlotClient.ErrorCatch(Sender : TObject; Exc : Exception);
var
  UserName: array[0..99] of char;
  i: integer;
begin
  // получение имени пользователя
  i:=SizeOf(UserName);
  GetUserName(UserName,DWORD(i));

  Send('/'+UserName+'/'+FormatDateTime ('hh:mm',Time)+'/'+Exc.message);
  // вывод сообщения об ошибке пользователю
  Application.ShowException(Exc);
end;

function TglMailSlotClient.Send(str: string):boolean;
var
  strMess: string[250];
  UserName: array[0..99] of char;
  h: THandle;
  i: integer;
begin
  // открытие канала : MyServer - имя сервера
  // (\\.\\mailslot\xxx - монитор работает на этом же ПК)
  // xxx - имя канала
  if FServerName = '' then
    FServerName := '.\';
  h:=CreateFile( PChar('\\' + FServerName + '\mailslot\' + FMailSlotName),
  GENERIC_WRITE, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0);
  if h <> INVALID_HANDLE_VALUE then
  begin
    strMess := str;
    // передача текста ошибки (запись в канал и закрытие канала)
    WriteFile(h, strMess, Length(strMess) + 1, DWORD(i), nil);
    CloseHandle(h);
  end;
  Result := h <> INVALID_HANDLE_VALUE;
end;

end.

Компонент TglMailSlotServer создает почтовый канал с именем MailSlotName и принимает входящие сообщения. Компонент TglMailSlotClient отправляет сообщения в канал с именем MailSlotName на машине ServerName.

Эти компонеты входят в состав библиотеки GlobusLib, распространяемой с исходными текстами.