unit Comm;

interface

uses
  Messages, WinTypes,WinProcs,Classes,
  SysUtils, {Excepts, }Forms{, MsgDlg};

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;
    FStat:TComStat;
    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;
1. Occasionally we will get a both a CN_RECEIVE and CN_EVENT in one message,
giving an lParamLo value of 5. TComm.WndProc is written to handle only one
Event at a time. The following solves this problem:
*)

procedure TComm.WndProc(var Msg:TMessage);
begin
  with Msg do
  begin
    if Msg=WM_COMMNOTIFY then
    begin
      if hComm < 0 then
        exit;
      if lParamLo AND CN_EVENT <> 0 then begin
        DoEvent;
      end;
      if lParamLo AND CN_RECEIVE <> 0 then begin
        GetCommError(hComm, FStat);
        DoReceive;
      end;
      if lParamLo AND CN_TRANSMIT <> 0 then begin
        GetCommError(hComm, FStat);
        DoTransmit;
      end;
    end else begin
      Result:=DefWindowProc(FWindowHandle,Msg,wParam,lParam);
    end;
  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;
begin
  if (hComm < 0) or (not Assigned(FOnReceive)) then
    exit;
  FOnReceive(Self, FStat.cbInQue);
end;

procedure TComm.DoTransmit;
begin
  if (hComm<0) or not Assigned(FOnTransmit) then
    exit;
  FOnTransmit(Self,FStat.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;
end;

(*
procedure TComm.Read(Data:PChar;Len:Word);
begin
  if hComm<0 then exit;
  if ReadComm(hComm,Data,Len)<0 then Error:=True;
end;
2. When processing the CN_RECEIVE message, you must read enough characters
to get below "RxFull" characters left in the receive queue. If this does not
happen, we will never see another WM_COMMNOTIFY, CN_RECEIVE.
The way I solve this problem is to check if the queue has less than RxFull
characters in it, and if not post another WM_COMMNOTIFY message to repeat
the read. See below...

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

  { if we haven't read below FRxFull, reshedule another COMMNOTIFY to read
        again....this will repeat until we are below
  }
  GetCommError(hComm, FStat);
  if FStat.cbInQue > FRxFull then
    PostMessage(FWindowHandle, WM_COMMNOTIFY, hComm, CN_RECEIVE);
end;

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

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

end.
