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

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.

[cc lang="delphi"] 

Добавить комментарий