unit COMPort;
interface
uses Windows, SysUtils, Classes;
type
TComPortNumber = (ComNone, Com1, Com2, Com3, Com4, Com5, Com6, Com7); // ggf. erweitern
TComPort = class(TObject)
private
FPort: TComPortNumber;
FPortHandle: THandle;
Fdcb: TDCB;
FRaiseOpenException: Boolean;
procedure SetPort(Value: TComPortNumber);
procedure SetDCB(const Value: TDCB);
protected
function GetHandle: THandle; virtual;
procedure ClosePort; virtual;
public
constructor Create;
destructor Destroy; override;
function Write(const buf; size: Cardinal): Cardinal;
function Read(var buf; size: Cardinal): Cardinal;
function ClearAll: Boolean; // clears the output and input buffer
function ClearInput: Boolean; // clears the input buffer
function ClearOutput: Boolean; // clears the output buffer
property Port: TComPortNumber read FPort write SetPort;
property DCB: TDCB read Fdcb write SetDCB;
property
Handle: THandle read GetHandle;
property RaiseOpenException: Boolean read FRaiseOpenException write FRaiseOpenException;
end;
const
// TDCB.Flags
fBinary = $0001; // binary mode, no EOF check
fParity = $0002;
fDtrControlEnable = $0010; // DTR flow control type
fRtsControlEnable = $1000; // RTS flow control enable
implementation
constructor TComPort.Create;
begin
inherited;
FPort := ComNone;
FPortHandle := 0;
FillChar(Fdcb, SizeOf(Fdcb), 0);
FRaiseOpenException := False;
end;
destructor TComPort.Destroy;
begin
ClosePort;
inherited;
end;
procedure TComPort.ClosePort;
begin
if FPortHandle <> 0 then begin
// Port schließen
CloseHandle(FPortHandle);
FPortHandle := 0;
end;
end;
function TComPort.GetHandle: THandle;
var
commtimeouts: TCommTimeouts;
portname: String;
begin
case FPort of
ComNone: begin
ClosePort;
Result := 0;
end;
else begin // case else
if FPortHandle <> 0 then begin
Result := FPortHandle;
exit;
end;
portname := '\\.\
COM' + IntToStr(Integer(FPort));
FPortHandle := CreateFile(PChar(portname), // name of
COM device to open
GENERIC_READ or GENERIC_WRITE, // read-write
access
0, nil, // not used
OPEN_EXISTING, // required for tape devices
0, 0); // not used
Result := FPortHandle;
if Result = INVALID_HANDLE_VALUE then Result := 0;
if (FPortHandle <> 0) then begin
// Device-Parameter setzen
Fdcb.DCBlength := SizeOf(Fdcb);
GetCommState(FPortHandle, Fdcb);
Fdcb.Flags := dcb.Flags and not (fDtrControlEnable or fRtsControlEnable) or fBinary;
Fdcb.BaudRate := CBR_19200; // baud
Fdcb.ByteSize := 8;
Fdcb.Parity := NOPARITY;
Fdcb.StopBits := ONESTOPBIT;
SetCommState(FPortHandle, Fdcb);
// Timeout für ReadFile() setzen
commtimeouts.ReadIntervalTimeout := 0;
commtimeouts.ReadTotalTimeoutMultiplier := 5;
commtimeouts.ReadTotalTimeoutConstant := 100;
SetCommTimeouts(FPortHandle, commtimeouts);
end;
if (Result = 0) and (FRaiseOpenException) then RaiseLastWin32Error;
end; // case else
end; // case
end;
procedure TComPort.SetPort(Value: TComPortNumber);
begin
if Value = FPort then exit;
FPort := Value;
ClosePort;
GetHandle; //
Handle erzeugen
end;
procedure TComPort.SetDCB(const Value: TDCB);
var h: THandle;
begin
h :=
Handle;
if h = 0 then exit;
if SetCommState(h, Value) then begin
if not GetCommState(h, Fdcb) then Move(Value, Fdcb, SizeOf(Fdcb));
end;
end;
function TComPort.Write(const buf; size: Cardinal): Cardinal;
begin
Result := 0;
if size = 0 then exit;
if not WriteFile(
Handle, buf, size, Result, nil) then Result := -1 * Result;
end;
function TComPort.Read(var buf; size: Cardinal): Cardinal;
begin
Result := 0;
if size = 0 then exit;
if not ReadFile(
Handle, buf, size, Result, nil) then Result := -1 * Result;
end;
function TComPort.ClearAll: Boolean; // clears the output and input buffer
begin
Result := PurgeComm(
Handle, PURGE_TXCLEAR or PURGE_RXCLEAR);
end;
function TComPort.ClearInput: Boolean; // clears the input buffer
begin
Result := PurgeComm(
Handle, PURGE_RXCLEAR);
end;
function TComPort.ClearOutput: Boolean; // clears the output buffer
begin
Result := PurgeComm(
Handle, PURGE_TXCLEAR);
end;
end.