home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
DP Tool Club 26
/
CD_ASCQ_26_1295.iso
/
vrac
/
caterm.zip
/
CATE.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1995-07-20
|
14KB
|
514 lines
unit Cate;
interface
uses Messages, WinTypes, WinProcs, Classes, Forms;
type
TPort = (NoPort, Com1, Com2, Com3, Com4, Com5, Com6, Com7, Com8, Com9);
TBaudRate = (____110, ____300, ____600, ___1200, ___2400, ___4800, ___9600, __14400,
__19200, __38400, __56000, _128000, _256000);
TParity = (None, Odd, Even, Mark, Space);
TDataBits = (_4, _5, _6, _7, _8);
TStopBits = (_1, _1_5, _2);
TCommEvent = (BreakMask, CtsMask, CtssMask, DsrMask, ErrMask, PerrMask, RingMask, RingTEMask,
RlsdMask, RlsdsMask, RxCharMask, RxFlagMask, TxEmptyMask);
TCommEvents = set of TCommEvent;
const
PortDefault = NoPort;
BaudRateDefault = ___9600;
ParityDefault = None;
DataBitsDefault = _8;
StopBitsDefault = _1;
ReadBufferSizeDefault = 2048;
WriteBufferSizeDefault = 2048;
RxFullDefault = 1024;
TxLowDefault = 1024;
EventsDefault = [];
type
TNotifyBreak = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
TNotifyCts = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
TNotifyCtss = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
TNotifyDsr = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
TNotifyErr = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
TNotifyPErr = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
TNotifyRing = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
TNotifyRlsd = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
TNotifyRlsds = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
TNotifyRxChar = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
TNotifyRxFlag = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
TNotifyTxEmpty = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
TNotifyRingTE = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
TNotifyReceiveEvent = procedure(Sender: TObject; Count: Word) of object;
TNotifyTransmitEvent = procedure(Sender: TObject; Count: Word) of object;
TCate= class(TComponent)
private
FPort: TPort;
FBaudRate: TBaudRate;
FParity: TParity;
FDataBits: TDataBits;
FStopBits: TStopBits;
FReadBufferSize: Word;
FWriteBufferSize: Word;
FRxFull: Word;
FTxLow: Word;
FEvents: TCommEvents;
FOnBreak: TNotifyBreak;
FOnCts: TNotifyCts;
FOnCtss: TNotifyCtss;
FOnDsr: TNotifyDsr;
FOnErr: TNotifyErr;
FOnPErr: TNotifyPErr;
FOnRing: TNotifyRing;
FOnRlsd: TNotifyRlsd;
FOnRlsds: TNotifyRlsds;
FOnRxChar: TNotifyRxChar;
FOnRxFlag: TNotifyRxFlag;
FOnTxEmpty: TNotifyTxEmpty;
FOnRingTE: TNotifyRingTE;
FOnReceive: TNotifyReceiveEvent;
FOnTransmit: TNotifyTransmitEvent;
FWindowHandle: hWnd;
hComm: Integer;
HasBeenLoaded: Boolean;
Error: Boolean;
{Comm Parameter Set Procedures...}
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);
{WM_COMMNOTIFY Event Procedures...}
procedure EvReceive;
procedure EvTransmit;
procedure CrackEvents;
{WM_COMMNOTIFY sub-events: EV_xxxxx}
procedure EvBreak;
procedure EvCts;
procedure EvCtss;
procedure EvDsr;
procedure EvErr;
procedure EvPErr;
procedure EvRing;
procedure EvRlsd;
procedure EvRlsds;
procedure EvRxChar;
procedure EvRxFlag;
procedure EvTxEmpty;
procedure EvRingTE;
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 OnBreak: TNotifyBreak read FOnBreak write FOnBreak;
property OnCts: TNotifyCts read FOnCts write FOnCts;
property OnCtss: TNotifyCtss read FOnCtss write FOnCtss;
property OnDsr: TNotifyDsr read FOnDsr write FOnDsr;
property OnErr: TNotifyErr read FOnErr write FOnErr;
property OnPErr: TNotifyPErr read FOnPErr write FOnPErr;
property OnRing: TNotifyRing read FOnRing write FOnRing;
property OnRlsd: TNotifyRlsd read FOnRlsd write FOnRlsd;
property OnRlsds: TNotifyRlsds read FOnRlsds write FOnRlsds;
property OnRxChar: TNotifyRxChar read FOnRxChar write FOnRxChar;
property OnRxFlag: TNotifyRxFlag read FOnRxFlag write FOnRxFlag;
property OnTxEmpty: TNotifyTxEmpty read FOnTxEmpty write FOnTxEmpty;
property OnRingTE: TNotifyRingTE read FOnRingTE write FOnRingTE;
property OnReceive: TNotifyReceiveEvent read FOnReceive write FOnReceive;
property OnTransmit: TNotifyTransmitEvent read FOnTransmit write FOnTransmit;
end;
procedure Register;
implementation
{************* Property Handlers *************}
procedure TCate.SetPort(Value: TPort);
const
CommStr: PChar= 'COM1:';
begin
FPort := Value;
if (csDesigning in ComponentState) or (not HasBeenLoaded) then exit;
if hComm >= 0 then CloseComm(hComm); {In case ReadBufferSize or WriteBufferSize is changing}
if Value= NoPort then exit;
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 TCate.SetBaudRate(Value: TBaudRate);
var
DCB: TDCB;
begin
FBaudRate := Value;
if hComm >= 0 then
begin
GetCommState(hComm, DCB);
case Value of
____110: DCB.BaudRate := CBR_110;
____300: DCB.BaudRate := CBR_300;
____600: DCB.BaudRate := CBR_600;
___1200: DCB.BaudRate := CBR_1200;
___2400: DCB.BaudRate := CBR_2400;
___4800: DCB.BaudRate := CBR_4800;
___9600: DCB.BaudRate := CBR_9600;
__14400: DCB.BaudRate := CBR_14400;
__19200: DCB.BaudRate := CBR_19200;
__38400: DCB.BaudRate := CBR_38400;
__56000: DCB.BaudRate := CBR_56000;
_128000: DCB.BaudRate := CBR_128000;
_256000: DCB.BaudRate := CBR_256000;
end;
SetCommState(DCB);
end;
end;
procedure TCate.SetParity(Value: TParity);
var
DCB: TDCB;
begin
FParity := Value;
if hComm < 0 then exit;
GetCommState(hComm, DCB);
case Value of
None: DCB.Parity := 0;
Odd: DCB.Parity := 1;
Even: DCB.Parity := 2;
Mark: DCB.Parity := 3;
Space: DCB.Parity := 4;
end;
SetCommState(DCB);
end;
procedure TCate.SetDataBits(Value: TDataBits);
var
DCB: TDCB;
begin
FDataBits := Value;
if hComm < 0 then exit;
GetCommState(hComm, DCB);
case Value of
_4: DCB.ByteSize := 4;
_5: DCB.ByteSize := 5;
_6: DCB.ByteSize := 6;
_7: DCB.ByteSize := 7;
_8: DCB.ByteSize := 8;
end;
SetCommState(DCB);
end;
procedure TCate.SetStopBits(Value: TStopBits);
var
DCB: TDCB;
begin
FStopBits := Value;
if hComm < 0 then exit;
GetCommState(hComm, DCB);
case Value of
_1: DCB.StopBits := 0;
_1_5: DCB.StopBits := 1;
_2: DCB.StopBits := 2;
end;
SetCommState(DCB);
end;
procedure TCate.SetReadBufferSize(Value: Word);
begin
if Value <= 8192 then
begin
FReadBufferSize := Value;
end else
FReadBufferSize := 8192;
SetPort(FPort);
end;
procedure TCate.SetWriteBufferSize(Value: Word);
begin
if Value <= 8192 then
begin
FWriteBufferSize := Value;
end else
FWriteBufferSize := 8192;
SetPort(FPort);
end;
procedure TCate.SetRxFull(Value: Word);
begin
FRxFull := Value;
if hComm < 0 then exit;
EnableCommNotification(hComm, FWindowHandle, FRxFull, FTxLow);
end;
procedure TCate.SetTxLow(Value: Word);
begin
FTxLow := Value;
if hComm < 0 then exit;
EnableCommNotification(hComm, FWindowHandle, FRxFull, FTxLow);
end;
procedure TCate.SetEvents(Value: TCommEvents);
var
EventMask: Word;
begin
FEvents := Value;
if hComm < 0 then exit;
EventMask := 0;
if BreakMask in FEvents then inc(EventMask, EV_BREAK);
if CtsMask in FEvents then inc(EventMask, EV_CTS);
if CtssMask in FEvents then inc(EventMask, EV_CTSS);
if DsrMask in FEvents then inc(EventMask, EV_DSR);
if ErrMask in FEvents then inc(EventMask, EV_ERR);
if PErrMask in FEvents then inc(EventMask, EV_PERR);
if RingMask in FEvents then inc(EventMask, EV_RING);
if RlsdMask in FEvents then inc(EventMask, EV_RLSD);
if RlsdsMask in FEvents then inc(EventMask, EV_RLSDS);
if RxCharMask in FEvents then inc(EventMask, EV_RXCHAR);
if RxFlagMask in FEvents then inc(EventMask, EV_RXFLAG);
if TxEmptyMask in FEvents then inc(EventMask, EV_TXEMPTY);
if RingTEMask in FEvents then inc(EventMask, EV_RINGTE);
SetCommEventMask(hComm, EventMask);
end;
{************* Event Handlers *************}
procedure TCate.WndProc(var Msg: TMessage);
begin
with Msg do
begin
if Msg= WM_COMMNOTIFY then
begin
case lParamLo of
CN_EVENT: CrackEvents;
CN_RECEIVE: EvReceive;
CN_TRANSMIT: EvTransmit;
end;
end
else
Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam);
end;
end;
procedure TCate.CrackEvents;
var
EventMask:Word;
begin
EventMask:=GetCommEventMask(hComm,Integer($FFFF));
if (BreakMask in Events) and (EventMask and EV_BREAK <> 0) then
EvBreak;
if (CtsMask in Events) and (EventMask and EV_CTS <> 0) then
EvCts;
if (CtssMask in Events) and (EventMask and EV_CTSS <> 0) then
EvCtss;
if (DsrMask in Events) and (EventMask and EV_DSR <> 0) then
EvDsr;
if (ErrMask in Events) and (EventMask and EV_ERR <> 0) then
EvErr;
if (PErrMask in Events) and (EventMask and EV_PERR <> 0) then
EvPErr;
if (RingMask in Events) and (EventMask and EV_RING <> 0) then
EvRing;
if (RlsdMask in Events) and (EventMask and EV_RLSD <> 0) then
EvRlsd;
if (RlsdsMask in Events) and (EventMask and EV_RLSDS <> 0) then
EvRlsds;
if (RxCharMask in Events) and (EventMask and EV_RXCHAR <> 0) then
EvRxChar;
if (RxFlagMask in Events) and (EventMask and EV_RXFLAG <> 0) then
EvRxFlag;
if (TxEmptyMask in Events) and (EventMask and EV_TXEMPTY <> 0) then
EvTxEmpty;
if (RingTEMask in Events) and (EventMask and EV_RINGTE <> 0) then
EvRingTE;
end;
procedure TCate.EvBreak;
begin
if Assigned(FOnBreak) then FOnBreak(Self, Events);
end;
procedure TCate.EvCts;
begin
if Assigned(FOnCts) then FOnCts(Self, Events);
end;
procedure TCate.EvCtss;
begin
if Assigned(FOnCtss) then FOnCtss(Self, Events);
end;
procedure TCate.EvDsr;
begin
if Assigned(FOnDsr) then FOnDsr(Self, Events);
end;
procedure TCate.EvErr;
begin
if Assigned(FOnErr) then FOnErr(Self, Events);
end;
procedure TCate.EvPErr;
begin
if Assigned(FOnPErr) then FOnPErr(Self, Events);
end;
procedure TCate.EvRing;
begin
if Assigned(FOnRing) then FOnRing(Self, Events);
end;
procedure TCate.EvRlsd;
begin
if Assigned(FOnRlsd) then FOnRlsd(Self, Events);
end;
procedure TCate.EvRlsds;
begin
if Assigned(FOnRlsds) then FOnRlsds(Self, Events);
end;
procedure TCate.EvRxChar;
begin
if Assigned(FOnRxChar) then FOnRxChar(Self, Events);
end;
procedure TCate.EvRxFlag;
begin
if Assigned(FOnRxFlag) then FOnRxFlag(Self, Events);
end;
procedure TCate.EvTxEmpty;
begin
if Assigned(FOnTxEmpty) then FOnTxEmpty(Self, Events);
end;
procedure TCate.EvRingTE;
begin
if Assigned(FOnRingTE) then FOnRingTE(Self, Events);
end;
procedure TCate.EvReceive;
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 TCate.EvTransmit;
var
Stat: TComStat;
begin
if (hComm < 0) or not Assigned(FOnTransmit) then exit;
GetCommError(hComm, Stat);
FOnTransmit(Self, Stat.cbOutQue);
end;
procedure TCate.Loaded;
begin
inherited Loaded;
HasBeenLoaded := True;
SetPort(FPort);
end;
constructor TCate.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 TCate.Destroy;
begin
DeallocatehWnd(FWindowHandle);
if hComm >= 0 then CloseComm(hComm);
inherited Destroy;
end;
procedure TCate.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 TCate.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 TCate.IsError: Boolean;
begin
IsError := Error;
Error := False;
end;
procedure Register;
begin
RegisterComponents('System', [TCate]);
end;
end.