Советы по 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.

[001161]




Содержание  Назад