unit SendThread;

interface

uses
  Windows, Messages, SysUtils, Classes, Syncobjs, Grids,
   VCLUtils, StdCtrls, ComCtrls, CommInt, HexGrid;


type
  TProcOfObj = procedure of object;
  TThreadBuf = array[0..1023] of char;


  ESendThreadError= class(Exception)
  private
    FErrorCode:integer;
  public
    constructor Create(aErrorCode:integer);
    property ErrorCode:integer read FErrorCode;
  end;
{
  Класс потока исполняет процедуры обмена данными с
  внешним интерфейсом.
  При этом задержки ожидания готовности данных не влияют
  на обработку сообщения основного потока
}

  TSendThread = class(TThread)
  private
    Overlapped: TOverlapped;

    FEndProcess: TProcOfObj;
    FExecutedProcess: TProcOfObj;
    FBuf:TThreadBuf;
    procedure DoOnEndProcess;
    procedure DoOnExecutedProcess;

  protected
    procedure Execute; override;
    procedure SetTimeouts(ACommTimeOuts:TCommTimeouts);
    function  GetTimeouts: TCommTimeouts;
    procedure CheckCommErrors;

  public
    FEvent: TEvent;
    CommPort: TComm;
    constructor Create(CreateSuspended: Boolean;var aCommPort: TComm);

    procedure   TimeOuts(ReadInterval,ReadMult,ReadConst,WriteMult,WriteConst:DWORD;K:DWORD);
    procedure   PurgePort;


    procedure   Synchronize(Method: TThreadMethod);
    function    WriteToComm(aCount:DWORD;var Buf: TThreadBuf):DWORD;
    function    WriteStrToComm(str:string):boolean;
    procedure   SetEventChar(ch:char);
    procedure   ReadNChar(var str: String; cnt :DWORD);
    function    ReadUntilChar(var Buf: TThreadBuf):DWORD;
    function    ReadStrUntilChar(var str: String):boolean;
    function    ReadFromComm(aCount:DWORD;var Buf: TThreadBuf):DWORD;
    property    OnExecuteProcess: TProcOfObj read FExecutedProcess write FExecutedProcess;
    property    OnEndProcess: TProcOfObj read FEndProcess write FEndProcess;
    property    CommTimeOuts: TCommTimeouts read GetTimeouts write SetTimeouts;
    property Terminated;
  end;

implementation

constructor ESendThreadError.Create(aErrorCode:integer);
begin
  FErrorCode:=aErrorCode;
  inherited Create(Format('Error code: %d',[aErrorCode]));
end;

procedure TSendThread.SetEventChar(ch:char);
var
    lpDCB:_DCB;
    lpEvtMask:Cardinal;

begin
  // Установить символ который будем ожидать
  GetCommState(CommPort.Handle,lpDCB);
  lpDCB.EvtChar:=ch;
  if not SetCommState(CommPort.Handle,lpDCB) then
    raise ESendThreadError.Create(GetLastError);
  // Установить , что ожидать будем только приход ожидаемого символа
  lpEvtMask:=EV_RXFLAG;
  if not SetCommMask(CommPort.Handle,lpEvtMask) then
    raise ESendThreadError.Create(GetLastError);
end;

function TSendThread.ReadUntilChar(var Buf: TThreadBuf):DWORD;
var err:DWORD;
    WaitRes:DWORD;
    lpErrors:Cardinal;
    lpEvtMask:Cardinal;
    FStat:TComStat;

begin
  result:=0;
 // SetupComm
  // Ожидание
  if not WaitCommEvent(CommPort.Handle,lpEvtMask,@Overlapped) then
  begin
    err:=GetLastError;
    case err of
      // Ошибка - команда не может быть выполнено немедленно
ERROR_IO_PENDING:
           // Ожидать выполнения события
         begin
           WaitRes:=WaitForSingleObject(FEvent.Handle, 2000);
           case WaitRes of
      WAIT_OBJECT_0:
             begin
               // Событие произошло
               if not GetOverlappedResult(CommPort.Handle,Overlapped, result, FALSE) then
               begin
                 // Ошибка выполнения операции
                 raise ESendThreadError.CreateFmt('GetOverlappedResult error: %d',[GetLastError]);
               end
               else
               begin
                 ClearCommError(CommPort.Handle,lpErrors,@FStat);
                 result:=ReadFromComm(FStat.cbInQue,Buf);
               end;
             end;
      WAIT_FAILED:
             // Ошибка
             raise ESendThreadError.CreateFmt('WAIT_FAILED error: %d',[GetLastError]);
      WAIT_ABANDONED:
             raise ESendThreadError.CreateFmt('WAIT_ABANDONED error: %d',[GetLastError]);
           else
             FEvent.SetEvent;
             raise ESendThreadError.CreateFmt('WaitForSingleObject error: %d',[GetLastError]);
           end
         end  {ERROR_IO_PENDING}
    else  {case err}
      // Другая ошика команды чтения
        raise ESendThreadError.CreateFmt('WaitCommEvent error: %d',[Err]);
    end {case}
  end
  else
  begin
    ClearCommError(CommPort.Handle,lpErrors,@FStat);
    if Self.Terminated then Abort;
    result:=ReadFromComm(FStat.cbInQue,Buf);
  end;   {if WaitCommEvent}
end;

function TSendThread.ReadFromComm(aCount:DWORD;var Buf: TThreadBuf):DWORD;
var err:DWORD;
    WaitRes:DWORD;
begin
    // Чтение данных из порта
   result:=0;
   if aCount=0 then abort;
   try
    if not Windows.ReadFile(CommPort.Handle,Buf,
                 aCount,result,@Overlapped)  then
    // 0 (false) - означает ошибку выполнения чтения
    begin
      err:=GetLastError;
      case err of
      // Ошибка - чтение не может быть выполнено немедленно
ERROR_IO_PENDING:
         begin
           // Ожидать выполнения чтения
           WaitRes:=WaitForSingleObject(FEvent.Handle, INFINITE);
           case WaitRes of
      WAIT_OBJECT_0:
             begin
               // Чтение завершилось
               if not GetOverlappedResult(CommPort.Handle,Overlapped, result, FALSE) then
               begin
                 // Ошибка выполнения операции
                 raise ESendThreadError.CreateFmt('GetOverlappedResult error: %d',[GetLastError]);
               end;
             end;
      WAIT_FAILED:
             // Ошибка
             raise ESendThreadError.CreateFmt('WAIT_FAILED error: %d',[GetLastError]);
      WAIT_ABANDONED:
             raise ESendThreadError.CreateFmt('WAIT_ABANDONED error: %d',[GetLastError]);
           else
             FEvent.SetEvent;
             raise ESendThreadError.CreateFmt('WaitForSingleObject error: %d',[GetLastError]);
           end
         end
      else  {case err}
      // Другая ошика команды чтения
        raise ESendThreadError.CreateFmt('ReadFile error: %d',[Err]);

      end; {case err}
   end  {if not Windows.ReadFile}
   finally
     CheckCommErrors;
     if Self.Terminated then Abort;
   end;
end;

function TSendThread.ReadStrUntilChar(var str: String):boolean;
var cnt:DWORD;
begin
  result:=false;
  cnt:= ReadUntilChar(FBuf);
  if cnt>0 then result:=true;
  SetString(str,FBuf,cnt);
end;

procedure   TSendThread.ReadNChar(var str: String; cnt :DWORD);
var N:DWORD;
    strTmp:string;
begin
  str:='';
  repeat
    N:=ReadFromComm(cnt,FBUF);
    SetString(strTmp,FBuf,N);
    str:=str+strTmp;
    cnt:=cnt-N;
  until cnt=0;
end;


function TSendThread.WriteToComm(aCount:DWORD;var Buf:TThreadBuf):DWORD;
var err:DWORD;
    WaitRes:DWORD;
begin
   result:=0;
    // Записать данные в порт
   if aCount=0 then abort;
   try
   if not Windows.WriteFile(CommPort.Handle,Buf,
                 aCount,result,@Overlapped) then
    // 0 (false) - означает ошибку выполнения записи
   begin
      err:=GetLastError;
      case err of
      // Ошибка - запись не может быть выполнена немедленно
ERROR_IO_PENDING:
         begin
           // Ожидать выполнения записи
           WaitRes:=WaitForSingleObject(FEvent.Handle, INFINITE);
           case WaitRes of
      WAIT_OBJECT_0:
             begin
               // Запись завершилось
               if not GetOverlappedResult(CommPort.Handle,Overlapped, result, FALSE) then
               begin
                 // Ошибка выполнения операции
                 raise ESendThreadError.CreateFmt('Write. GetOverlappedResult error: %d',[GetLastError]);
               end;
             end;
      WAIT_FAILED:
             // Ошибка
             raise ESendThreadError.CreateFmt('Write. WAIT_FAILED error: %d ',[GetLastError]);
      WAIT_ABANDONED:
             raise ESendThreadError.CreateFmt('Write. WAIT_ABANDONED error: %d ',[GetLastError]);
           else
             FEvent.SetEvent;
             raise ESendThreadError.CreateFmt('Write. WaitForSingleObject error: %d ',[GetLastError]);
           end  {case WaitRes}
         end  {ERROR_IO_PENDING}
      else  {case err}
      // Другая ошика команды записи
        raise ESendThreadError.CreateFmt('Write to CommPort error: %d ',[Err]);
      end; {case err}
   end  {if not Windows.WriteFile}
   finally
     CheckCommErrors;
     if Self.Terminated then Abort;
   end;
end;

function  TSendThread.WriteStrToComm(str:string):boolean;
var cnt:DWORD;
begin
  result:=false;
  cnt:=FormatBuf(FBuf,SizeOf(FBuf),'%s',2,[str]);
  if cnt=WriteToComm(cnt,FBuf) then result:=true
end;


procedure TSendThread.CheckCommErrors;
var
    lpErrors:Cardinal;
    FStat:TComStat;
    ErrMsg:string;
begin
   ErrMsg:='';
   if ClearCommError(CommPort.Handle,lpErrors,@FStat) then
     if lpErrors<>0 then
     begin
       if (CE_BREAK and lpErrors)<>0 then
         ErrMsg:=ErrMsg+'The hardware detected a break condition.'+Chr($0a)+Chr($0d);
       if (CE_FRAME and lpErrors)<>0 then
         ErrMsg:=ErrMsg+'The hardware detected a framing error.'+Chr($0a)+Chr($0d);
       if (CE_IOE	 and lpErrors)<>0 then
         ErrMsg:=ErrMsg+'An I/O error occurred during communications with the device.'+Chr($0a)+Chr($0d);
       if (CE_OVERRUN and lpErrors)<>0 then
         ErrMsg:=ErrMsg+'A character-buffer overrun has occurred. The next character is lost.'+Chr($0a)+Chr($0d);
       if (CE_RXPARITY and lpErrors)<>0 then
         ErrMsg:=ErrMsg+'The hardware detected a parity error.'+Chr($0a)+Chr($0d);
       if (CE_DNS and lpErrors)<>0 then
         ErrMsg:=ErrMsg+'A parallel device is not selected.'+Chr($0a)+Chr($0d);
       if (CE_MODE and lpErrors)<>0 then
         ErrMsg:=ErrMsg+'The requested mode is not supported, or the hFile parameter is invalid.'+Chr($0a)+Chr($0d);
       if (CE_OOP and lpErrors)<>0 then
         ErrMsg:=ErrMsg+'A parallel device signaled that it is out of paper.'+Chr($0a)+Chr($0d);
       if (CE_PTO and lpErrors)<>0 then
         ErrMsg:=ErrMsg+'A time-out occurred on a parallel device.'+Chr($0a)+Chr($0d);
       if (CE_RXOVER and lpErrors)<>0 then
         ErrMsg:=ErrMsg+'An input buffer overflow has occurred.'+Chr($0a)+Chr($0d);
       if (CE_TXFULL and lpErrors)<>0 then
         ErrMsg:=ErrMsg+'The application tried to transmit a character, but the output buffer was full.'+Chr($0a)+Chr($0d);

       raise ESendThreadError.CreateFmt('Error: %x'+Chr($0a)+Chr($0d)+'%s',[lpErrors,ErrMsg]);
     end;
end;



procedure TSendThread.Synchronize(Method: TThreadMethod);
begin
  inherited Synchronize(Method);
end;

procedure TSendThread.Execute;
begin
  try
    try
      DoOnExecutedProcess;
    finally
      DoOnEndProcess;
      FEvent.Free;
    end;
  except        // Необработанное исключение нельзя выпускать из
                // потока, иначе происходит сбой.
    on E:Exception do MsgBox('Thread exception',E.Message,mb_OK)
  end;
end;

procedure TSendThread.SetTimeouts(ACommTimeOuts:TCommTimeouts);
begin
  Windows.SetCommTimeouts(CommPort.Handle,ACommTimeOuts)
end;

function TSendThread.GetTimeouts:TCommTimeouts;
begin
  Windows.GetCommTimeouts(CommPort.Handle,Result);
end;


procedure TSendThread.TimeOuts(ReadInterval,ReadMult,ReadConst,WriteMult,WriteConst:DWORD;K:DWORD);
var ATimeOuts:TCommTimeouts;
begin

  // максимальное время (мс) между принятием двух
  // последовательных символов. 0 означает, что установка не используется
  ATimeOuts.ReadIntervalTimeout:=ReadInterval*K;
  // множитель на количество запрошенных байт
  // определяющий максимальное врем (мс) ожидания приема
  ATimeOuts.ReadTotalTimeoutMultiplier:=ReadMult*K;
  // константа определяющая максимальное время (мс) ожидания
  // приема. Складывается с произведением множителя и количества байт
  ATimeOuts.ReadTotalTimeoutConstant:=ReadConst*K;
  //
  //
  ATimeOuts.WriteTotalTimeoutMultiplier:=WriteMult*K;
  //
  //
  ATimeOuts.WriteTotalTimeoutConstant:=WriteConst*K;
  SetTimeouts(ATimeOuts);

end;

Procedure TSendThread.PurgePort;
begin
  PurgeComm(CommPort.Handle, PURGE_RXABORT +
                             PURGE_RXCLEAR +
                             PURGE_TXABORT +
                             PURGE_TXCLEAR);

end;

procedure TSendThread.DoOnEndProcess;
begin
  if Assigned(FEndProcess) then
    FEndProcess;
end;


procedure TSendThread.DoOnExecutedProcess;
begin
  if Assigned(FExecutedProcess) then
    FExecutedProcess;
end;

constructor TSendThread.Create(CreateSuspended: Boolean;var aCommPort: TComm);
begin
  FEvent:=TEvent.Create(nil,true,false,'');
  FillChar(Overlapped, Sizeof(Overlapped), 0);
  Overlapped.hEvent := FEvent.Handle;
  CommPort:=aCommPort;
  Self.FreeOnTerminate:=true;
  inherited Create(CreateSuspended);
end;



end.
