[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]

    {
    Someone was looking for a serial communication control, I just don't
    quite remember who it was.  Hopefully this code will help him/her..
    }
    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.

[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]