Code:

//... создание канала с именем MailSlotName - по этому имени к нему

//    будут обращаться клиенты

h := CreateMailSlot(PChar('\\.\mailslot\' + MailSlotName), 0, MAILSLOT_WAIT_FOREVER,nil);

if h = INVALID_HANDLE_VALUE then begin

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

Code:

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;

Code:

{

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 begin

   raise Exception.Create('TglMailSlotServer: Ошибка создания канала !');

end;

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

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;

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.