unit Comm;

interface
uses
  Messages, WinTypes, WinProcs, Classes, Forms;

type

  TPort = (tptNone, tptOne, tptTwo, tptThree, tptFour, tptFive, tptSix,
    tptSeven,
    tptEight);
  TBaudRate = (tbr110, tbr300, tbr600, tbr1200, tbr2400, tbr4800, tbr9600,
    tbr14400,
    tbr19200, tbr38400, tbr56000, tbr128000, tbr256000);
  TParity = (tpNone, tpOdd, tpEven, tpMark, tpSpace);
  TDataBits = (tdbFour, tdbFive, tdbSix, tdbSeven, tdbEight);
  TStopBits = (tsbOne, tsbOnePointFive, tsbTwo);
  TCommEvent = (tceBreak, tceCts, tceCtss, tceDsr, tceErr, tcePErr, tceRing,
    tceRlsd,
    tceRlsds, tceRxChar, tceRxFlag, tceTxEmpty);
  TCommEvents = set of TCommEvent;

const

  PortDefault = tptNone;
  BaudRateDefault = tbr9600;
  ParityDefault = tpNone;
  DataBitsDefault = tdbEight;
  StopBitsDefault = tsbOne;
  ReadBufferSizeDefault = 2048;
  WriteBufferSizeDefault = 2048;
  RxFullDefault = 1024;
  TxLowDefault = 1024;
  EventsDefault = [];

type

  TNotifyEventEvent = procedure(Sender: TObject; CommEvent: TCommEvents) of
    object;
  TNotifyReceiveEvent = procedure(Sender: TObject; Count: Word) of object;
  TNotifyTransmitEvent = procedure(Sender: TObject; Count: Word) of object;

  TComm = class(TComponent)
  private
    FPort: TPort;
    FBaudRate: TBaudRate;
    FParity: TParity;
    FDataBits: TDataBits;
    FStopBits: TStopBits;
    FReadBufferSize: Word;
    FWriteBufferSize: Word;
    FRxFull: Word;
    FTxLow: Word;
    FEvents: TCommEvents;
    FOnEvent: TNotifyEventEvent;
    FOnReceive: TNotifyReceiveEvent;
    FOnTransmit: TNotifyTransmitEvent;
    FWindowHandle: hWnd;
    hComm: Integer;
    HasBeenLoaded: Boolean;
    Error: Boolean;
    procedure SetPort(Value: TPort);
    procedure SetBaudRate(Value: TBaudRate);
    procedure SetParity(Value: TParity);
    procedure SetDataBits(Value: TDataBits);
    procedure SetStopBits(Value: TStopBits);
    procedure SetReadBufferSize(Value: Word);
    procedure SetWriteBufferSize(Value: Word);
    procedure SetRxFull(Value: Word);
    procedure SetTxLow(Value: Word);
    procedure SetEvents(Value: TCommEvents);
    procedure WndProc(var Msg: TMessage);
    procedure DoEvent;
    procedure DoReceive;
    procedure DoTransmit;
  protected
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Write(Data: PChar; Len: Word);
    procedure Read(Data: PChar; Len: Word);
    function IsError: Boolean;
  published
    property Port: TPort read FPort write SetPort default PortDefault;
    property BaudRate: TBaudRate read FBaudRate write SetBaudRate
      default BaudRateDefault;
    property Parity: TParity read FParity write SetParity default ParityDefault;
    property DataBits: TDataBits read FDataBits write SetDataBits
      default DataBitsDefault;
    property StopBits: TStopBits read FStopBits write SetStopBits
      default StopBitsDefault;
    property WriteBufferSize: Word read FWriteBufferSize
      write SetWriteBufferSize default WriteBufferSizeDefault;
    property ReadBufferSize: Word read FReadBufferSize
      write SetReadBufferSize default ReadBufferSizeDefault;
    property RxFullCount: Word read FRxFull write SetRxFull
      default RxFullDefault;
    property TxLowCount: Word read FTxLow write SetTxLow default TxLowDefault;
    property Events: TCommEvents read FEvents write SetEvents
      default EventsDefault;
    property OnEvent: TNotifyEventEvent read FOnEvent write FOnEvent;
    property OnReceive: TNotifyReceiveEvent read FOnReceive write FOnReceive;
    property OnTransmit: TNotifyTransmitEvent read FOnTransmit write
      FOnTransmit;
  end;

procedure Register;

implementation

procedure TComm.SetPort(Value: TPort);
const

  CommStr: PChar = 'COM1:';
begin

  FPort := Value;
  if (csDesigning in ComponentState) or
    (Value = tptNone) or (not HasBeenLoaded) then
    exit;
  if hComm >= 0 then
    CloseComm(hComm);
  CommStr[3] := chr(48 + ord(Value));
  hComm := OpenComm(CommStr, ReadBufferSize, WriteBufferSize);
  if hComm < 0 then
  begin
    Error := True;
    exit;
  end;
  SetBaudRate(FBaudRate);
  SetParity(FParity);
  SetDataBits(FDataBits);
  SetStopBits(FStopBits);
  SetEvents(FEvents);
  EnableCommNotification(hComm, FWindowHandle, FRxFull, FTxLow);
end;

procedure TComm.SetBaudRate(Value: TBaudRate);
var

  DCB: TDCB;
begin

  FBaudRate := Value;
  if hComm >= 0 then
  begin
    GetCommState(hComm, DCB);
    case Value of
      tbr110: DCB.BaudRate := CBR_110;
      tbr300: DCB.BaudRate := CBR_300;
      tbr600: DCB.BaudRate := CBR_600;
      tbr1200: DCB.BaudRate := CBR_1200;
      tbr2400: DCB.BaudRate := CBR_2400;
      tbr4800: DCB.BaudRate := CBR_4800;
      tbr9600: DCB.BaudRate := CBR_9600;
      tbr14400: DCB.BaudRate := CBR_14400;
      tbr19200: DCB.BaudRate := CBR_19200;
      tbr38400: DCB.BaudRate := CBR_38400;
      tbr56000: DCB.BaudRate := CBR_56000;
      tbr128000: DCB.BaudRate := CBR_128000;
      tbr256000: DCB.BaudRate := CBR_256000;
    end;
    SetCommState(DCB);
  end;
end;

procedure TComm.SetParity(Value: TParity);
var

  DCB: TDCB;
begin

  FParity := Value;
  if hComm < 0 then
    exit;
  GetCommState(hComm, DCB);
  case Value of
    tpNone: DCB.Parity := 0;
    tpOdd: DCB.Parity := 1;
    tpEven: DCB.Parity := 2;
    tpMark: DCB.Parity := 3;
    tpSpace: DCB.Parity := 4;
  end;
  SetCommState(DCB);
end;

procedure TComm.SetDataBits(Value: TDataBits);
var

  DCB: TDCB;
begin

  FDataBits := Value;
  if hComm < 0 then
    exit;
  GetCommState(hComm, DCB);
  case Value of
    tdbFour: DCB.ByteSize := 4;
    tdbFive: DCB.ByteSize := 5;
    tdbSix: DCB.ByteSize := 6;
    tdbSeven: DCB.ByteSize := 7;
    tdbEight: DCB.ByteSize := 8;
  end;
  SetCommState(DCB);
end;

procedure TComm.SetStopBits(Value: TStopBits);
var

  DCB: TDCB;
begin

  FStopBits := Value;
  if hComm < 0 then
    exit;
  GetCommState(hComm, DCB);
  case Value of
    tsbOne: DCB.StopBits := 0;
    tsbOnePointFive: DCB.StopBits := 1;
    tsbTwo: DCB.StopBits := 2;
  end;
  SetCommState(DCB);
end;

procedure TComm.SetReadBufferSize(Value: Word);
begin

  FReadBufferSize := Value;
  SetPort(FPort);
end;

procedure TComm.SetWriteBufferSize(Value: Word);
begin

  FWriteBufferSize := Value;
  SetPort(FPort);
end;

procedure TComm.SetRxFull(Value: Word);
begin

  FRxFull := Value;
  if hComm < 0 then
    exit;
  EnableCommNotification(hComm, FWindowHandle, FRxFull, FTxLow);
end;

procedure TComm.SetTxLow(Value: Word);
begin

  FTxLow := Value;
  if hComm < 0 then
    exit;
  EnableCommNotification(hComm, FWindowHandle, FRxFull, FTxLow);
end;

procedure TComm.SetEvents(Value: TCommEvents);
var

  EventMask: Word;
begin

  FEvents := Value;
  if hComm < 0 then
    exit;
  EventMask := 0;
  if tceBreak in FEvents then
    inc(EventMask, EV_BREAK);
  if tceCts in FEvents then
    inc(EventMask, EV_CTS);
  if tceCtss in FEvents then
    inc(EventMask, EV_CTSS);
  if tceDsr in FEvents then
    inc(EventMask, EV_DSR);
  if tceErr in FEvents then
    inc(EventMask, EV_ERR);
  if tcePErr in FEvents then
    inc(EventMask, EV_PERR);
  if tceRing in FEvents then
    inc(EventMask, EV_RING);
  if tceRlsd in FEvents then
    inc(EventMask, EV_RLSD);
  if tceRlsds in FEvents then
    inc(EventMask, EV_RLSDS);
  if tceRxChar in FEvents then
    inc(EventMask, EV_RXCHAR);
  if tceRxFlag in FEvents then
    inc(EventMask, EV_RXFLAG);
  if tceTxEmpty in FEvents then
    inc(EventMask, EV_TXEMPTY);
  SetCommEventMask(hComm, EventMask);
end;

procedure TComm.WndProc(var Msg: TMessage);
begin

  with Msg do
  begin
    if Msg = WM_COMMNOTIFY then
    begin
      case lParamLo of
        CN_EVENT: DoEvent;
        CN_RECEIVE: DoReceive;
        CN_TRANSMIT: DoTransmit;
      end;
    end
    else
      Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam);
  end;
end;

procedure TComm.DoEvent;
var

  CommEvent: TCommEvents;
  EventMask: Word;
begin

  if (hComm < 0) or not Assigned(FOnEvent) then
    exit;
  EventMask := GetCommEventMask(hComm, Integer($FFFF));
  CommEvent := [];
  if (tceBreak in Events) and (EventMask and EV_BREAK <> 0) then
    CommEvent := CommEvent + [tceBreak];
  if (tceCts in Events) and (EventMask and EV_CTS <> 0) then
    CommEvent := CommEvent + [tceCts];
  if (tceCtss in Events) and (EventMask and EV_CTSS <> 0) then
    CommEvent := CommEvent + [tceCtss];
  if (tceDsr in Events) and (EventMask and EV_DSR <> 0) then
    CommEvent := CommEvent + [tceDsr];
  if (tceErr in Events) and (EventMask and EV_ERR <> 0) then
    CommEvent := CommEvent + [tceErr];
  if (tcePErr in Events) and (EventMask and EV_PERR <> 0) then
    CommEvent := CommEvent + [tcePErr];
  if (tceRing in Events) and (EventMask and EV_RING <> 0) then
    CommEvent := CommEvent + [tceRing];
  if (tceRlsd in Events) and (EventMask and EV_RLSD <> 0) then
    CommEvent := CommEvent + [tceRlsd];
  if (tceRlsds in Events) and (EventMask and EV_Rlsds <> 0) then
    CommEvent := CommEvent + [tceRlsds];
  if (tceRxChar in Events) and (EventMask and EV_RXCHAR <> 0) then
    CommEvent := CommEvent + [tceRxChar];
  if (tceRxFlag in Events) and (EventMask and EV_RXFLAG <> 0) then
    CommEvent := CommEvent + [tceRxFlag];
  if (tceTxEmpty in Events) and (EventMask and EV_TXEMPTY <> 0) then
    CommEvent := CommEvent + [tceTxEmpty];
  FOnEvent(Self, CommEvent);
end;

procedure TComm.DoReceive;
var

  Stat: TComStat;
begin

  if (hComm < 0) or not Assigned(FOnReceive) then
    exit;
  GetCommError(hComm, Stat);
  FOnReceive(Self, Stat.cbInQue);
  GetCommError(hComm, Stat);
end;

procedure TComm.DoTransmit;
var
  Stat: TComStat;
begin
  if (hComm < 0) or not Assigned(FOnTransmit) then
    exit;
  GetCommError(hComm, Stat);
  FOnTransmit(Self, Stat.cbOutQue);
end;

procedure TComm.Loaded;
begin
  inherited Loaded;
  HasBeenLoaded := True;
  SetPort(FPort);
end;

constructor TComm.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FWindowHandle := AllocateHWnd(WndProc);
  HasBeenLoaded := False;
  Error := False;
  FPort := PortDefault;
  FBaudRate := BaudRateDefault;
  FParity := ParityDefault;
  FDataBits := DataBitsDefault;
  FStopBits := StopBitsDefault;
  FWriteBufferSize := WriteBufferSizeDefault;
  FReadBufferSize := ReadBufferSizeDefault;
  FRxFull := RxFullDefault;
  FTxLow := TxLowDefault;
  FEvents := EventsDefault;
  hComm := -1;
end;

destructor TComm.Destroy;
begin
  DeallocatehWnd(FWindowHandle);
  if hComm >= 0 then
    CloseComm(hComm);
  inherited Destroy;
end;

procedure TComm.Write(Data: PChar; Len: Word);
begin
  if hComm < 0 then
    exit;
  if WriteComm(hComm, Data, Len) < 0 then
    Error := True;
  GetCommEventMask(hComm, Integer($FFFF));
end;

procedure TComm.Read(Data: PChar; Len: Word);
begin
  if hComm < 0 then
    exit;
  if ReadComm(hComm, Data, Len) < 0 then
    Error := True;
  GetCommEventMask(hComm, Integer($FFFF));
end;

function TComm.IsError: Boolean;
begin
  IsError := Error;
  Error := False;
end;

procedure Register;
begin
  RegisterComponents('Additional', [TComm]);
end;

end.