Network

Asynchronous communication

Asynchronous communication

Question

I would try to compare VB and delphi about communication with

asynchronous port (modem by example). I didn't find an objet or

something like that to opencomm, writecom, readcomm, closecomm.

Answer

A:

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.