unit unitMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

const
  WM_ConnectClientPipe = WM_USER+1342;
  WM_DisconnectClientPipe = WM_USER+1343;
  WM_MessagesAllClients = WM_USER+1344;
  WM_MessagesClientsPrior= WM_USER+1346;
type
  TfrmMain = class(TForm)
    mmoLog: TMemo;
    btnStart: TButton;
    procedure btnStartClick(Sender: TObject);
  private
    { Private declarations }
    procedure WMConnectClientPipe(var aMsg:TMessage);message WM_ConnectClientPipe;
    procedure WMDisconnectClientPipe(var aMsg:TMessage);message WM_DisconnectClientPipe;
    procedure WMMessagesAllClients(var aMsg:TMessage);message WM_MessagesAllClients;

    procedure WMMessagesClientsPrior(var aMsg:TMessage);message WM_MessagesClientsPrior;
  public
    { Public declarations }
  end;

const
  MAX_PIPE_CLIENTS=20;//максимальное кол-во клиентов
  BUFFSIZE=100;//размер буфера
  TIME_OUT=1000;//таймаут


type
  RPipe = packed record
    hPipe: THANDLE;
    hIdThread: Cardinal;
    sPrior:string;
    Live: Boolean;
  end;
type
  arrChar= array[0..BUFFSIZE] of Char;//для передачи в функции

var
  frmMain: TfrmMain;
  Clients:array[1..MAX_PIPE_CLIENTS] of RPipe;
  countClients,counLiveClients,countPriorClients,countPriorClientsMess:Integer;
  sTemp:string;

implementation

{$R *.dfm}

//чтение канала
function RdNameClientpipe(aHandle,ahPipe:HWND; var aInBuf:arrChar):Boolean;
var
  hEventRd: THANDLE;
  OverLapRd:OVERLAPPED;
  bytesRead,lastError:Cardinal;
  rd:Boolean;
begin
  Result := True;
  // Создаем событие ожидания завершения чтения из канала.
  hEventRd := CreateEvent(nil, True, False, '');
  FillChar(OverLapRd, sizeof(OVERLAPPED), 0);
  OverLapRd.hEvent := hEventRd;
  //получаем приоритет клиента в первом сообщении от него
  rd := ReadFile (ahPipe, aInBuf, BUFFSIZE*SizeOf(Char), bytesRead, @OverLapRd);
  if not rd then
    lastError := GetLastError;
  if lastError = ERROR_IO_PENDING then  // Ожидаем завершения ввода-вывода
    WaitForSingleObject (hEventRd, INFINITE);
  if not rd then
  begin
    lastError := GetLastError;
    case lastError of
    ERROR_IO_PENDING: // Ожидаем завершения операции
      WaitForSingleObject (hEventRd, INFINITE);
    ERROR_BROKEN_PIPE: // Экземпляр канала сломался, завершаем обслуживание.
      Result := False;
    else
      Result := False;
    end;
  end;
  CloseHandle(hEventRd);
end;

//запись в именованный канал
function WtNameClientpipe(ahPipe:HWND; aOutBuf:arrChar):Boolean;
var
  hEventWrt:THANDLE;
  OverLapWrt:OVERLAPPED;
  wrt:Boolean;
  bytesWritten,lastError:Cardinal;
begin
  Result:=False;
  // Создаем событие ожидания завершения записи в канал.
  hEventWrt := CreateEventW (nil, true, false, nil);
  FillChar(OverLapWrt, sizeof(OVERLAPPED), 0);
  OverLapWrt.hEvent := hEventWrt;
  //пишем клиенту его индекс который был выбран из свободных сот
  wrt := WriteFile (ahPipe,aOutBuf ,BUFFSIZE*SizeOf(Char), bytesWritten,@OverLapWrt);
  // Проверка на три вида ошибки: IO_PENDING, NO_DATA и остальные.
  // Для случая IO_PENDING ожидать завершения асинхронного ввода-вывода
  // на событии клиента, во всех остальных случаях, кроме NO_DATA
  // считать клиента умершим и отметить факт его смерти в описании клиента.
  if not wrt then
  begin
    lastError := GetLastError;
    if lastError = ERROR_IO_PENDING then //Ждем завершения операции
      WaitForSingleObject (hEventWrt, INFINITE)
    else
    begin
      if lastError <> ERROR_NO_DATA then //Клиент умер по причине lastError
        Exit;
    end;
  end;
  Result:=True;
end;

function ServerProc(Param: Pointer):Integer; stdcall;
type
  PHWND = ^HWND;
var
  idThread:Cardinal;
  handle:HWND;//дескриптор окна
  hPipe:HWND;
  inBuf,outBuf:arrChar;
  ExitLoop,prior:Boolean;
  i:Integer;
  ClientIndex:Integer;
  preobr:string;
begin
  handle:=PHWND(Param)^;
  // Создать серверную часть канала на локальной машине
  hPipe := CreateNamedPipe ('\\.\PIPE\test', // Имя канала = 'test'.
                  PIPE_ACCESS_DUPLEX or      // Двусторонний канал
                  FILE_FLAG_OVERLAPPED,      // Асинхронный ввод-вывод
                  PIPE_WAIT or               // Ожидать сообщений
                  PIPE_READMODE_MESSAGE or   // Обмен в канале производится пакетами
                  PIPE_TYPE_MESSAGE,
                  MAX_PIPE_CLIENTS,        // Максимальное числе экземпляров канала.
                  BUFFSIZE*SizeOf(Char), // Размеры буферов чтения/записи.
                  BUFFSIZE*SizeOf(Char),
                  TIME_OUT,                  // Тайм-аут.
                  nil);                      // Атрибуты безопасности.
  if hPipe=INVALID_HANDLE_VALUE then
    Exit;
   // Ожидаем подключения клиента.
  ConnectNamedPipe(hPipe, nil);
  for i := 1 to MAX_PIPE_CLIENTS do
    if Clients.Live=False then
    begin
       Clients.Live:=True;
       Clients.hPipe:=hPipe;
       ClientIndex:=i;
       Break;
    end;

  SendMessage(handle,WM_ConnectClientPipe,ClientIndex,0);
  if not rdNameClientpipe(handle,hPipe,inBuf) then
  begin
    SendMessage(handle,WM_DisconnectClientPipe,ClientIndex,0);
    Clients[ClientIndex].Live:=False;
    Clients[ClientIndex].hPipe:=0;
    CloseHandle (hPipe);
    DisconnectNamedPipe (hPipe);  // Разрушаем экземпляр канала
    ExitThread(0);
  end;
  preobr:= inBuf;
  Clients[ClientIndex].sPrior:=preobr;
  Clients[ClientIndex].Live:=True;

  preobr:=IntToStr(ClientIndex);
  Move(preobr[1],outBuf,BUFFSIZE);
  if not WtNameClientpipe(Clients[ClientIndex].hPipe,outBuf) then
  begin
    SendMessage(handle,WM_DisconnectClientPipe,ClientIndex,0);
    Clients[ClientIndex].Live:=False;
    Clients[ClientIndex].hPipe:=0;
    CloseHandle (hPipe);
    DisconnectNamedPipe (hPipe);  // Разрушаем экземпляр канала
    ExitThread(0);
  end;

  Clients[ClientIndex].Live:=True;
  Clients[ClientIndex].hPipe:=hPipe;
  Clients[ClientIndex+1].hIdThread:=CreateThread(nil, 0, @ServerProc, @Param^,0, idThread);
  ExitLoop:=true;
  while ExitLoop do
  begin
      ExitLoop:=rdNameClientpipe(handle,hPipe,inBuf);
      prior:=False;
      countPriorClients:=0;
      for i := 1 to MAX_PIPE_CLIENTS do
      begin
        if Clients.Live then
        begin
          if Clients.sPrior='1' then
          begin
            prior:=True;
            Inc(countPriorClients);
          end;
        end;
      end;
      if prior then
      begin
        if Clients[ClientIndex].sPrior='1' then
          SendMessage(handle,WM_MessagesClientsPrior,countPriorClients,lparam(StrPas(inBuf)));
      end
      else
          SendMessage(handle,WM_MessagesAllClients,ClientIndex,lparam(StrPas(inBuf)));

  end;
  SendMessage(handle,WM_DisconnectClientPipe,ClientIndex,0);
  Clients[ClientIndex].Live:=False;
  Clients[ClientIndex].hPipe:=0;
  Clients[ClientIndex].sPrior:='';
  CloseHandle (hPipe);
  DisconnectNamedPipe (hPipe);  // Разрушаем экземпляр канала
  ExitThread(0);                // Завершаем обслуживающий поток.
end;

procedure TfrmMain.btnStartClick(Sender: TObject);
var
  idThread:Cardinal;
begin
  //запуск потока
  Clients[1].hIdThread:=CreateThread(nil, 0, @ServerProc, @WindowHandle, 0, idThread);
end;

procedure TfrmMain.WMConnectClientPipe(var aMsg: TMessage);
begin
  frmMain.mmoLog.Lines.Add('Подключился клиент '+IntToStr(aMsg.WParam));
end;

procedure TfrmMain.WMDisconnectClientPipe(var aMsg: TMessage);
begin
  frmMain.mmoLog.Lines.Add('Клиент '+IntToStr(aMsg.WParam)+' отключился от сервера');
end;

procedure TfrmMain.WMMessagesAllClients(var aMsg: TMessage);
var
  i:Integer;
begin
  sTemp:=sTemp+' '+string(aMsg.LParam);
  Inc(countClients);
  counLiveClients:=0;
  for i := 1 to MAX_PIPE_CLIENTS do
    if Clients.Live then
    begin
      Inc(counLiveClients);//кол-во живых клиентов
    end;
  if countClients>=counLiveClients then
  begin
    frmMain.mmoLog.Lines.Add(TimeToStr(Time)+' '+sTemp);
    sTemp:='';
    countClients:=0;
  end;

end;

procedure TfrmMain.WMMessagesClientsPrior(var aMsg: TMessage);
var
  i:Integer;
begin
  sTemp:=sTemp+' '+string(aMsg.LParam);
  Inc(countPriorClientsMess);
  if countPriorClientsMess>=aMsg.WParam then
  begin
    frmMain.mmoLog.Lines.Add(TimeToStr(Time)+' '+sTemp);
    sTemp:='';
    countPriorClientsMess:=0;
  end;
end;
end.

Клиент

unit unitMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TfrmMain = class(TForm)
    btnStart: TButton;
    lblprioritet: TLabel;
    edtPrioritet: TEdit;
    procedure btnStartClick(Sender: TObject);
  private
    { Private declarations }

  public
    { Public declarations }
  end;

const
  MAX_PIPE_CLIENTS=20;//максимальное кол-во клиентов
  BUFFSIZE=100;//размер буфера
  TIME_OUT=1000;//таймаут
type
  arrChar= array[0..BUFFSIZE] of Char;//для передачи в функции

var
  frmMain: TfrmMain;

implementation

{$R *.dfm}


//чтение канала
function RdNameClientpipe(ahPipe:HWND; var aInBuf:arrChar):Boolean;
var
  hEventRd: THANDLE;
  OverLapRd:OVERLAPPED;
  bytesRead,lastError:Cardinal;
  rd:Boolean;
begin
  Result := True;
  // Создаем событие ожидания завершения чтения из канала.
  hEventRd := CreateEvent(nil, True, False, '');
  FillChar(OverLapRd, sizeof(OVERLAPPED), 0);
  OverLapRd.hEvent := hEventRd;
  //получаем приоритет клиента в первом сообщении от него
  rd := ReadFile (ahPipe, aInBuf, BUFFSIZE*SizeOf(Char), bytesRead, @OverLapRd);
  if not rd then
    lastError := GetLastError;
  if lastError = ERROR_IO_PENDING then  // Ожидаем завершения ввода-вывода
    WaitForSingleObject (hEventRd, INFINITE);
  if not rd then
  begin
    lastError := GetLastError;
    case lastError of
    ERROR_IO_PENDING: // Ожидаем завершения операции
      WaitForSingleObject (hEventRd, INFINITE);
    ERROR_BROKEN_PIPE: // Экземпляр канала сломался, завершаем обслуживание.
      Result := False;
    else
      Result := False;
    end;
  end;
  CloseHandle(hEventRd);
end;


//запись в именованный канал
function WtNameClientpipe(ahPipe:HWND; aOutBuf:arrChar):Boolean;
var
  hEventWrt:THANDLE;
  OverLapWrt:OVERLAPPED;
  wrt:Boolean;
  bytesWritten,lastError:Cardinal;
begin
  Result:=True;
  // Создаем событие ожидания завершения записи в канал.
  hEventWrt := CreateEventW (nil, true, false, nil);
  FillChar(OverLapWrt, sizeof(OVERLAPPED), 0);
  OverLapWrt.hEvent := hEventWrt;
  //пишем клиенту его индекс который был выбран из свободных сот
  wrt := WriteFile (ahPipe,aOutBuf ,BUFFSIZE*SizeOf(Char), bytesWritten,@OverLapWrt);
  // Проверка на три вида ошибки: IO_PENDING, NO_DATA и остальные.
  // Для случая IO_PENDING ожидать завершения асинхронного ввода-вывода
  // на событии клиента, во всех остальных случаях, кроме NO_DATA
  // считать клиента умершим и отметить факт его смерти в описании клиента.
  if not wrt then
    lastError := GetLastError;
  if lastError = ERROR_IO_PENDING then  // Ожидаем завершения ввода-вывода
    WaitForSingleObject (hEventWrt, INFINITE);
  if not wrt then
  begin
    lastError := GetLastError;
    case lastError of
    ERROR_IO_PENDING: // Ожидаем завершения операции
      WaitForSingleObject (hEventWrt, INFINITE);
    ERROR_BROKEN_PIPE: // Экземпляр канала сломался, завершаем обслуживание.
      Result := False;
    else
      Result := False;
    end;
  end;
  CloseHandle(hEventWrt);
end;

function ClientProc (Param: Pointer):Integer; stdcall;
var
  hPipe:HWND;
  hEventWrt,hEventRd:THandle;
  OverLapWrt,OverLapRd:OVERLAPPED;
  wrt,rd:Boolean;
  bytesWritten,bytesWritten2,bytesRead:Cardinal;
  outBuf,inIndex:arrChar;
  lastError:Cardinal;
  strTemp:^string;
begin
  // Соединиться с сервером
  hPipe := CreateFile('\\.\PIPE\test',
    GENERIC_WRITE or // Доступ на чтение/запись
    GENERIC_READ,
    FILE_SHARE_READ or // Разделенный доступ
    FILE_SHARE_WRITE,
    nil,
    OPEN_EXISTING,   // Канал должен существовать
    FILE_FLAG_OVERLAPPED, // Использовать асинхронный ввод/вывод
    0);
  if hPipe = INVALID_HANDLE_VALUE then
    Exit;
  strTemp:=Param;
  Move(strTemp^,outBuf,BUFFSIZE);
  if not  WtNameClientpipe(hPipe,outBuf) then
  begin
    CloseHandle(hPipe);
    ExitThread(0);
  end;
  if not rdNameClientpipe(hPipe,inIndex) then
  begin
    CloseHandle (hPipe);
    DisconnectNamedPipe (hPipe);  // Разрушаем экземпляр канала
    ExitThread(0);
  end;
  while True do
  begin
    Sleep(1000);
    if not WtNameClientpipe(hPipe,inIndex) then
      Break;
  end;
  CloseHandle(hPipe);
  ExitThread(0);
end;

procedure TfrmMain.btnStartClick(Sender: TObject);
var
  idThread:Cardinal;
  prior:Integer;
  strTemp:string;
begin
  strTemp:=edtPrioritet.Text;
  CreateThread(nil, 0, @ClientProc, pchar(strTemp), 0, idThread);
end;
end.