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.