unit Com;
interface
uses
WinTypes, WinProcs, Classes, SysUtils;
type
TRTSMode = (RTS_DISABLED, RTS_ENABLED, RTS_HANDSHAKE, RTS_TOGGLE);
TDTRMode = (DTR_DISABLED, DTR_ENABLED, DTR_HANDSHAKE);
TParity = (NOPARITY, ODDPARITY, EVENPARITY, MARKPARITY, SPACEPARITY);
TStopbits = (ONESTOPBIT, ONE5STOPBITS, TWOSTOPBITS);
TCOM =
class(TComponent)
private
FDCB: TDCB;
FHandle: Cardinal;
FTimeouts: TCommTimeouts;
FError: Cardinal;
FComNo: byte;
FBaud: word;
FParity: TParity;
FDatabits: byte;
FStopbits: TStopbits;
function GetRTS: boolean;
procedure SetRTS(
const Value: boolean);
function GetDTR: boolean;
procedure SetDTR(
const Value: boolean);
function GetDCD: boolean;
function GetDSR: boolean;
function GetRI: boolean;
function GetCTS: boolean;
function GetIsOpen: boolean;
function GetInBufUsed: cardinal;
function GetOutBufUsed: cardinal;
public
constructor Create(AOwner: TComponent);
override;
destructor Destroy;
override;
function TestComPortAvailable(ComNo: integer): boolean;
function Open(ComNo: integer; RTSMode: TRTSMode; DTRMode: TDTRMode): boolean;
function RxFlush: boolean;
function TxFlush: boolean;
function Send(Data: Char): boolean;
overload;
function Send(Data: PChar; Len: cardinal): boolean;
overload;
function GetChar(
var data: Char): boolean;
procedure Close;
procedure Reset;
published
property ComNo: byte
read FComNo;
property Baud: word
read FBaud
write FBaud;
property Databits: byte
read FDatabits
write FDatabits;
property Stopbits: TStopbits
read FStopbits
write FStopbits;
property Parity: TParity
read FParity
write FParity;
property IsOpen: boolean
read GetIsOpen;
property InBufUsed: cardinal
read GetInBufUsed;
property OutBufUsed: cardinal
read GetOutBufUsed;
property Error: cardinal
read FError;
property RTS: boolean
read GetRTS
write SetRTS;
property CTS: boolean
read GetCTS;
property DTR: boolean
read GetDTR
write SetDTR;
property DSR: boolean
read GetDSR;
property RI: boolean
read GetRI;
property DCD: boolean
read GetDCD;
end;
var FCOM: TCOM;
implementation
{----------------------------------------------------------------------------------------------}
constructor TCOM.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FHandle := INVALID_HANDLE_VALUE;
Baud := CBR_9600;
Databits := 8;
Parity := NOPARITY;
StopBits := ONESTOPBIT;
end;
{----------------------------------------------------------------------------------------------}
destructor TCOM.Destroy;
begin
if IsOpen
then Close;
{ Port schließen falls geöffnet }
inherited destroy;
end;
{----------------------------------------------------------------------------------------------}
function TCOM.TestComPortAvailable(ComNo: integer): boolean;
begin
Result := Open(ComNo, RTS_DISABLED, DTR_DISABLED);
end;
{----------------------------------------------------------------------------------------------}
function TCOM.Open(ComNo: integer; RTSMode: TRTSMode; DTRMode: TDTRMode): boolean;
var init:
string;
begin
if FHandle = INVALID_HANDLE_VALUE
then
begin
init := '
\\.\COM' + IntToStr(ComNo);
FHandle := CreateFile(@init[1],
GENERIC_READ
or GENERIC_WRITE,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if FHandle <> INVALID_HANDLE_VALUE
then
begin
FComNo := ComNo;
// aktuelle Einstellungen ermitteln
if GetCommState(FHandle, FDCB)
then
begin
// rudimentäre Parameter setzen
FDCB.Baudrate := FBaud;
FDCB.Bytesize := Databits;
FDCB.Parity := Ord(FParity);
FDCB.Stopbits := Ord(FStopbits);
// RTS Modus setzen
FDCB.flags := FDCB.flags
and $CFFB;
{RTS aus}
case RTSMode
of
RTS_ENABLED: FDCB.flags := FDCB.flags
or $1000;
{RTS ein}
RTS_HANDSHAKE: FDCB.flags := FDCB.flags
or $2004;
{RTS Handshake ein (gekoppelt an RX Buffer 0= Empfangspuffer zu 3/4 voll)}
RTS_TOGGLE: FDCB.flags := FDCB.flags
or $3000;
{RTS gekoppelt an Tx Buffer (1=Daten im Sendepuffer)}
end;
// DTR Modus setzen
FDCB.flags := FDCB.flags
and $FFC7;
{DTR aus (und bleibt aus)}
case DTRMode
of
DTR_ENABLED: FDCB.flags := FDCB.flags
or $0010;
{DTR ein (und bleibt ein)}
DTR_HANDSHAKE: FDCB.flags := FDCB.flags
or $0028;
{DTR Handshake ein}
end;
if SetCommState(FHandle, FDCB)
then
begin
if SetupComm(FHandle, 1024, 1024)
then {Rx-/Tx-Buffer-Einstellungen}
begin
FTimeouts.ReadIntervalTimeout := 0;
{Timeoutzeiten setzen}
FTimeouts.ReadTotalTimeoutMultiplier := 0;
FTimeouts.ReadTotalTimeoutConstant := 1;
FTimeouts.WriteTotalTimeoutMultiplier := 0;
FTimeouts.WriteTotalTimeoutConstant := 0;
SetCommTimeouts(FHandle, FTimeouts);
end;
end;
end;
end;
end;
FError := GetLastError;
if Error <> 0
then
begin
Close;
end;
Result := Error = 0;
{ Ergebnis zurückgeben }
end;
{-----------------------------------------------------------------------------------------------}
function TCOM.GetCTS: boolean;
var nStatus: cardinal;
begin
Result := false;
if FHandle <> INVALID_HANDLE_VALUE
then
begin
if GetCommModemStatus(FHandle, nStatus)
then
Result := (nStatus
and MS_CTS_ON) > 0;
end;
end;
{-----------------------------------------------------------------------------------------------}
function TCOM.GetDSR: boolean;
var nStatus: cardinal;
begin
Result := false;
if FHandle <> INVALID_HANDLE_VALUE
then
begin
if GetCommModemStatus(FHandle, nStatus)
then
Result := (nStatus
and MS_DSR_ON) > 0;
end;
end;
{-----------------------------------------------------------------------------------------------}
function TCOM.GetIsOpen: boolean;
begin
Result := FHandle <> INVALID_HANDLE_VALUE;
end;
{-----------------------------------------------------------------------------------------------}
function TCOM.GetInBufUsed: cardinal;
var
Comstat: _Comstat;
Errors: DWord;
begin
if ClearCommError(FHandle, Errors, @Comstat)
then
Result := Comstat.cbInQue
else Result := 0;
end;
{-----------------------------------------------------------------------------------------------}
function TCOM.GetOutBufUsed: cardinal;
var
Comstat: _Comstat;
Errors: DWord;
begin
if ClearCommError(FHandle, Errors, @Comstat)
then
Result := Comstat.cbOutQue
else Result := 0;
end;
{-----------------------------------------------------------------------------------------------}
function TCOM.GetRI: boolean;
var nStatus: cardinal;
begin
Result := false;
if FHandle <> INVALID_HANDLE_VALUE
then
begin
if GetCommModemStatus(FHandle, nStatus)
then
Result := (nStatus
and MS_RING_ON) > 0;
end;
end;
{-----------------------------------------------------------------------------------------------}
function TCOM.GetRTS: boolean;
begin
Result := false;
if GetCommState(FHandle, FDCB)
then
begin
Result := (FDCB.Flags
and $3000) > 0;
end;
end;
{-----------------------------------------------------------------------------------------------}
procedure TCOM.SetRTS(
const Value: boolean);
begin
if (Value = True)
then
EscapeCommFunction(FHandle, WinTypes.SETRTS)
else
EscapeCommFunction(FHandle, WinTypes.CLRRTS);
end;
{-----------------------------------------------------------------------------------------------}
function TCOM.GetDTR: boolean;
begin
Result := false;
if GetCommState(FHandle, FDCB)
then
begin
Result := (FDCB.Flags
and $0010) > 0;
end;
end;
{-----------------------------------------------------------------------------------------------}
procedure TCOM.SetDTR(
const Value: boolean);
begin
if (Value = True)
then
EscapeCommFunction(FHandle, WinTypes.SETDTR)
else
EscapeCommFunction(FHandle, WinTypes.CLRDTR);
end;
{-----------------------------------------------------------------------------------------------}
function TCOM.GetDCD: boolean;
var nStatus: cardinal;
begin
Result := false;
if FHandle <> INVALID_HANDLE_VALUE
then
begin
if GetCommModemStatus(FHandle, nStatus)
then
Result := (nStatus
and MS_RLSD_ON) > 0;
end;
end;
{-----------------------------------------------------------------------------------------------}
procedure TCOM.Close;
begin
if CloseHandle(FHandle)
then { Schnittstelle schließen }
FHandle := INVALID_HANDLE_VALUE;
FError := GetLastError;
end;
{-----------------------------------------------------------------------------------------------}
procedure TCOM.Reset;
begin
if not EscapeCommFunction(FHandle, WinTypes.RESETDEV)
then
FError := GetLastError;
end;
{-----------------------------------------------------------------------------------------------}
function TCOM.RxFlush: boolean;
begin
if FHandle <> INVALID_HANDLE_VALUE
then
begin
PurgeComm(FHandle, PURGE_RXCLEAR);
FError := GetLastError;
end;
Result := FError = 0;
end;
{-----------------------------------------------------------------------------------------------}
function TCOM.TxFlush: boolean;
begin
if FHandle <> INVALID_HANDLE_VALUE
then
begin
PurgeComm(FHandle, PURGE_TXCLEAR);
FError := GetLastError;
end;
Result := FError = 0;
end;
{-----------------------------------------------------------------------------------------------}
function TCOM.Send(Data: Char): boolean;
var nWritten, nCount: Cardinal;
begin
Result := false;
if FHandle <> INVALID_HANDLE_VALUE
then
begin
nCount := SizeOf(Data);
if WriteFile(FHandle, Data, nCount, nWritten,
nil)
then
begin
Result := nCount = nWritten;
end;
FError := GetLastError;
end;
end;
{-----------------------------------------------------------------------------------------------}
function TCOM.Send(Data: PChar; Len: cardinal): boolean;
var nWritten, nCount: Cardinal;
begin
Result := false;
if FHandle <> INVALID_HANDLE_VALUE
then
begin
nCount := Len;
if WriteFile(FHandle, Data^, nCount, nWritten,
nil)
then
begin
Result := nCount = nWritten;
end;
FError := GetLastError;
end;
end;
{-----------------------------------------------------------------------------------------------}
function TCOM.GetChar(
var data: Char): boolean;
var nCount, nRead: cardinal;
begin
Result := false;
if FHandle <> INVALID_HANDLE_VALUE
then
begin
nCount := SizeOf(data);
if InBufUsed >= nCount
then
begin
if ReadFile(FHandle, data, nCount, nRead,
nil)
then
begin
Result := nCount = nRead;
end;
end;
FError := GetLastError;
end;
end;
end.