Ассинхронная связь

Written on 01 Ноября 2007. Posted in [Delphi] Система. Железо

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.

форум делфи