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.
|
