unit Serial;

interface

uses
  Windows, SysUtils;

function IsPortAvailable(Number:Integer):Boolean;

type
  TSerial = class(TObject)
  private
    hCom:Cardinal;
    procedure FSetBaudRate(ABaudRate:DWord);
    function FGetBaudRate:DWord;
    function FGetInQueue:DWord;
    function FGetOutQueue:DWord;
    procedure FSetDTR(Status:Boolean);
    procedure FSetRTS(Status:Boolean);
    function FGetCTS:Boolean;
    function FGetDSR:Boolean;
    function FGetRLSD:Boolean;
    function FGetRING:Boolean;
    function gms:DWord;
  public
    constructor Create(Number:Integer;ABaudRate:DWord);
    destructor Destroy; override;
    function ReadByte(var AByte:Byte):Boolean;
    function WriteByte(AByte:Byte):Boolean;
    property BaudRate:DWord
      read FGetBaudRate write FSetBaudRate;
    property InQueue:DWord read FGetInQueue;
    property OutQueue:DWord read FGetOutQueue;
    procedure ClearInBuffer;
    procedure ClearOutBuffer;
    property DTR:Boolean write FSetDTR;
    property RTS:Boolean write FSetRTS;
    property CTS:Boolean read FGetCTS;
    property DSR:Boolean read FGetDSR;
    property RLSD:Boolean read FGetRLSD;
    property RING:Boolean read FGetRING;
end;

type
  TSerialException = class(Exception)
  public
    constructor Create(const Msg:String);
end;

implementation

function IsPortAvailable(Number:Integer):Boolean;
var Handle:Cardinal;
    PortName:String;
begin
  PortName:=Format('COM%d',[Number]);
  Handle:=CreateFile(
    PChar(PortName),
    GENERIC_READ or GENERIC_WRITE,0,
    nil,OPEN_EXISTING,0,0);
  IsPortAvailable:=Handle<>INVALID_HANDLE_VALUE;
  CloseHandle(Handle);
end;

constructor TSerial.Create(Number:Integer;ABaudRate:DWord);
var PortName:String;
    cto:COMMTIMEOUTS;
begin
  inherited Create;
  PortName:=Format('COM%d',[Number]);
  hCom:=CreateFile(
    PChar(PortName),
    GENERIC_READ or GENERIC_WRITE,0,
    nil,OPEN_EXISTING,0,0);

  cto.ReadIntervalTimeout:=10;
  cto.ReadTotalTimeoutMultiplier:=100;
  cto.ReadTotalTimeoutConstant:=1000;
  cto.WriteTotalTimeoutMultiplier:=2;
  cto.WriteTotalTimeoutConstant:=10;
  SetCommTimeouts(hCom,cto);
  FSetBaudRate(ABaudRate);

  SetupComm(hCom,1000,1000);

  if hCom=INVALID_HANDLE_VALUE then
    raise TSerialException.Create(
      'Port '+PortName+' není k dispozici')
end;

destructor TSerial.Destroy();
begin
  CloseHandle(hCom);
  inherited Destroy;
end;

function TSerial.ReadByte(var AByte:Byte):Boolean;
var d:DWord;
begin
  d:=0;
  ReadFile(hCom,AByte,1,d,nil);
  ReadByte:=(d=1);
end;

function TSerial.WriteByte(AByte:Byte):Boolean;
var d:DWord;
begin
  d:=0;
  WriteFile(hCom,AByte,1,d,nil);
  WriteByte:=(d=1);
end;

function TSerial.FGetBaudRate:DWord;
var dcs:DCB;
begin
  dcs.DCBlength:=sizeof(dcs);
  GetCommState(hCom,dcs);
  FGetBaudRate:=dcs.BaudRate;
end;

procedure TSerial.FSetBaudRate(ABaudRate:DWord);
var dcs:DCB;
begin
  dcs.DCBlength:=sizeof(dcs);
  dcs.BaudRate:=ABaudRate;
  dcs.Flags:=0;
  dcs.wReserved:=0;
  dcs.XonLim:=0;
  dcs.XoffLim:=0;
  dcs.ByteSize:=8;
  dcs.Parity:=NOPARITY;
  dcs.StopBits:=ONESTOPBIT;
  dcs.XonChar:=#0;
  dcs.XoffChar:=#0;
  dcs.ErrorChar:=#0;
  dcs.EofChar:=#0;
  dcs.EvtChar:=#0;
  dcs.wReserved1:=0;
  SetCommState(hCom,dcs);
end;

function TSerial.FGetInQueue:DWord;
var Errors:DWord;
    Stat:COMSTAT;
begin
   ClearCommError(hCom,Errors,@Stat);
   FGetInQueue:=Stat.cbInQue;
end;

function TSerial.FGetOutQueue:DWord;
var Errors:DWord;
    Stat:COMSTAT;
begin
   ClearCommError(hCom,Errors,@Stat);
   FGetOutQueue:=Stat.cbOutQue;
end;

procedure TSerial.ClearInBuffer;
begin
  PurgeComm(hCom,PURGE_RXCLEAR);
end;

procedure TSerial.ClearOutBuffer;
begin
  PurgeComm(hCom,PURGE_TXCLEAR);
end;

procedure TSerial.FSetDTR(Status:Boolean);
begin
  if(Status) then
    EscapeCommFunction(hCom,SETDTR)
  else
    EscapeCommFunction(hCom,CLRDTR);
end;

procedure TSerial.FSetRTS(Status:Boolean);
begin
  if(Status) then
    EscapeCommFunction(hCom,SETRTS)
  else
    EscapeCommFunction(hCom,CLRRTS);
end;

function TSerial.FGetCTS:Boolean;
begin
  FGetCTS:=(gms and MS_CTS_ON)>0;
end;

function TSerial.FGetDSR:Boolean;
begin
  FGetDSR:=(gms and MS_DSR_ON)>0;
end;

function TSerial.FGetRLSD:Boolean;
begin
  FGetRLSD:=(gms and MS_RLSD_ON)>0;
end;

function TSerial.FGetRING:Boolean;
begin
  FGetRING:=(gms and MS_RING_ON)>0;
end;

function TSerial.gms:DWord;
var d:DWord;
begin
  GetCommModemStatus(hCom,d);
  gms:=d;
end;

constructor TSerialException.Create(const Msg:String);
begin
  inherited;
end;

end.
