Serial Communication

unit Comm;
interface

uses
  Messages,WinTypes,WinProcs,Classes,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;
    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);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;  end;  
procedure TComm.Read(Data:PChar;Len:Word);  begin
  if hComm<0 then exit;
  if ReadComm(hComm,Data,Len)<0 then Error:=True;end;  
function TComm.IsError:Boolean;begin
  IsError:=Error;
  Error:=False;end;
procedure Register;begin
  RegisterComponents('Additional',[TComm]);end;
end.
{------------------------------------------------------------------------------}
unit Main;  
interface 

uses
  Messages,WinTypes, WinProcs, Classes,
  Graphics, Forms, Controls,StdCtrls, Comm;  
type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Comm1: TComm;
    procedure Memo1KeyPress(Sender: TObject; var Key: Char);
    procedure Comm1Receive(Sender: TObject; Count: Word);
  end;  
var
  Form1: TForm1;
implementation 
{$R *.FRM}
procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);begin
  Comm1.Write(@Key,SizeOf(Key));end;
procedure TForm1.Comm1Receive(Sender: TObject; Count: Word);var
  CommChar:Char;
  i:Word;begin
  for i:=1 to Count do
  begin
    Comm1.Read(@CommChar,SizeOf(CommChar));
    PostMessage(Memo1.Handle,WM_CHAR,Word(CommChar),0);
  end;end;
begin
  RegisterClasses([TForm1, TMemo, TComm]);
  Form1 := TForm1.Create(Application);end.