unit uCOMPort;
interface
uses Windows, SysUtils;
const
//--Konstanten für den Statusreport------------------------------------------------------------
parity :
array[0..4]
of String = ('
Keine','
Ungerade','
Gerade','
Markierung','
Leerzeichen');
stopbits :
array[0..2]
of String = ('
1','
1,5','
2');
//---------------------------------------------------------------------------------------------
//--Konstanten zum einfachen Setzen der Portflags----------------------------------------------
dcb_Binary = $00000001;
// Binärer Modus - In Windows immer auf 1!
dcb_ParityCheck = $00000002;
// Paritätsüberprüfung
dcb_OutxCtsFlow = $00000004;
// CTS Flusskontrolle - Sendekontrolle mit Hilfe von CTS
dcb_OutxDsrFlow = $00000008;
// DSR Flusskontrolle - Sendekontroll mit Hilfe von DSR
dcb_DtrControlDisable = $00000000;
// DTR Flusskontrolle - Schließt DTR auf 0 bei Verbindung und hält es auf 0
dcb_DtrControlEnable = $00000010;
// DTR Flusskontrolle - Öffnet DTR auf 1 bei Verbindung und hält es auf 1
dcb_DtrControlHandshake = $00000020;
// DTR Flusskontrolle - Handshake-Funktion.
dcb_DtrControlMask = $00000030;
dcb_DsrSensitvity = $00000040;
// Zustandsänderung auf DSR überwachen
dcb_TXContinueOnXoff = $00000080;
// Stellt ein, ob die Übertragung bei XOff angehalten wird oder nicht
dcb_OutX = $00000100;
// Flusskontrolle mit XOn/XOff beim Senden
dcb_InX = $00000200;
// Flusskontrolle mit XOn/XOff beim Empfangen
dcb_ErrorChar = $00000400;
// Bestimmt, ob Bytes mit falscher Parität durch den Error-Char ersetzt wird.
dcb_NullStrip = $00000800;
// Null-Bytes werden beim Empfangen ignoriert
dcb_RtsControlDisable = $00000000;
// RTS-Flusskontrolle - Schließt RTS auf 0 bei Verbindung und hält es auf 0
dcb_RtsControlEnable = $00001000;
// RTS-Flusskontrolle - Öffnet RTS auf 1 bei Verbindung und hält es auf 1
dcb_RtsControlHandshake = $00002000;
// RTS-Flusskontrolle - Handshake-Funktion
dcb_RtsControlToggle = $00003000;
// RTS-Flusskontrolle - RTS ist an wenn Bytes zu senden sind, wenn keine zu senden sind ist RTS auf 0
dcb_RtsControlMask = $00003000;
// RTS-Flusskontrolle
dcb_AbortOnError = $00004000;
// Wenn ein Fehler auftritt, stoppt jede Transmission und der
// Fehler muss mit Hilfe von ClearCommError beseitigt werden.
dcb_Reserveds = $FFFF8000;
// Reserviert! Nicht benutzen!
//------------------------------------------------------------------------------------------------------------------------
type TComPort =
class
private
PortHandle : Integer;
// Handle (u.a. Zeiger) auf den COM-Port.
DCB : TDCB;
// Data-Control-Block-Struktur zum Kontrollieren der Parameter der seriellen Schnittstelle
procedure GetDCB;
procedure SetParity (Parity : byte);
// Den Modus der Paritätskontrolle:
function GetParity : byte;
// 0 = Keine, 1=ungerade, 2=gerade, 3=Merkierung, 4=Leerzeichen
procedure SetBaudRate (Baudrate : Word);
// Setzt die Übertragungsgeschwindigkeit des Ports in Baud
function GetBaudrate : Word;
function GetStopBits : byte;
// Setzt die Anzahl der Stopbits
procedure SetStopBits (bits : byte);
// 0 = 1 Stopbit, 1 = 1.5 Stopbits, 2 = 2 Stopbits
function GetByteSize : byte;
// Fragt die Anzhal der Bits/Byte ab.
procedure SetByteSize (bytesize : byte);
// Setzt die Anzahl der Bits/Byte (Standard: 8)
public
function OpenCOM (Port : pchar) : Integer;
// Öffnet COM-Port (Parameter-Beispiel: 'COM1')
procedure CloseCOM;
// Schließt das Handle für den COM-Port
//-------------------------------------------Ausgaben - Indikatoren für angeschlossene Geräte
procedure TXD (State : integer);
// TxD = Sendeleitung --> Hier Prozedur für Dauerspannung auf TxD
procedure RTS (State : integer);
// "Request-To-Send" --> Computer signalisiert, dass er senden möchte
procedure DTR (State : integer);
// "Data-Terminal-Ready" --> Computer ist bereit
//-------------------------------------------Eingaben - Indikatoren für bestimmte Ereignisse.
function CTS : integer;
// "Clear-To-Send" --> Dem Computer wird angezeigt,
// dass das angeschlossene Gerät bereit ist Daten zu emfpangen
function DSR : integer;
// "Data-Set-Ready" --> Angeschlossenes Gerät ist bereit
function RI : integer;
// "Ring-Indicator" --> Klingelzeichen, ähnlich beim Telefon
function DCD : integer;
// "Data-Carrier-Detect --> Computer ist bereit Daten zu empfangen
function INPUTS : integer;
//--------------------------------------------------------------------------------------------
function GetHndl : Integer;
// Gibt das geöffnete Handle des Ports zurück
//--------------------------------------------------------------------------------------------
function GetFlags : Integer;
// Fragt die Port-Flags ab.
function SetFlags (Flag : Integer; Enable : Boolean) : boolean;
//Setzt die Port-Flags (siehe weiter oben)
//------------------------------------------Sendefunktionen-----------------------------------
procedure BufferSize (Size : Integer);
// Setzt die Größe des Sende- und Empfangspuffers für Zeichenübertragungen
function CharInTXBuffer : Cardinal;
// Aktuelle Länge des Sendepuffers
function CharInRXBuffer : Cardinal;
// Aktuelle Länge des Empfangspuffers
procedure ClearBuffer;
// Sende- und Empfangspuffer werden gelöscht
procedure SENDBYTE (Dat: Integer);
// Byte über die serielle Schnittstelle senden
procedure SENDSTRING(Buffer: Pchar);
// Text über die serielle Schnittstelle senden
function READBYTE() : Integer;
// Byte über die serielle Schnittstelle empfangen
function READSTRING() : Pchar;
// Text über die serielle Schnittstelle empfangen
procedure Timeouts (TOut : Integer);
// Setzt die Timeouts zum Senden
function GetStatusReport :
String;
// Gibt einen ausführlich formulierten Statusreport des Ports zurück.
//---------------------------------------------------------------------------------------------
//-------------Eigenschaftsfestsetzungen - zum leichteren Setzen der Porteigenschaften---------
property Parity : byte
read GetParity
write SetParity;
property BaudRate : Word
read GetBaudRate
write SetBaudRate;
property StopBits : byte
read GetStopBits
write SetStopBits;
property ByteSize : byte
read GetByteSize
write SetByteSize;
//*********************************************************************************************
destructor Destroy;
override;
constructor Create (AutoInit : Integer);
//*********************************************************************************************
end;
implementation
constructor TComport.Create (AutoInit : Integer);
begin
case AutoInit
of
1 : OpenCOM('
COM1');
2 : OpenCOM('
COM2');
end;
{CASE}
end;
function TComPort.OpenCOM (port : pchar) : Integer;
var
PortStr, Parameter :
String;
begin
Result := 0;
// Wenn Port-Handle geöffnet, dann Handle schließen
if PortHandle > 0
then CloseHandle(PortHandle);
// übermittelter COM-Port 'herausfiltern'
Parameter := port;
PortStr := copy(Parameter,1,4);
// COM-Port öffnen
PortHandle := CreateFile (PChar(PortStr), GENERIC_READ
or GENERIC_WRITE,
0,
nil,OPEN_EXISTING,0,0);
//Status des Ports überprüfen und DCB-Struktur füllen
GetCommState(PortHandle,dcb);
//DCB-Struktur mit Standardwerten füllen
BuildCommDCB(PChar(Parameter),dcb);
//Eigene Flags setzen
DCB.Flags := 1;
//Änderungen auf den Port anwenden und auf Erfolg überprüfen
if SetCommState (PortHandle, DCB)
then Result := 1;
end;
procedure TComPort.CloseCOM;
begin
//Port schließen und Handle zurücksetzen (wegen OpenCOM!)
GetCommState(PortHandle,dcb);
SetParity(0);
SetBaudrate(1200);
SetStopBits(0);
SetByteSize(8);
SetCommState(PortHandle,dcb);
CloseHandle(PortHandle);
PortHandle := 0;
end;
procedure TComport.TXD (State: Integer);
//TxD bei 0 auf Sendemodus stellen, bei 1 auf Dauerspannung (Sendebetrieb nicht möglich)
begin
if State=0
then
EscapeCommFunction(PortHandle,CLRBREAK)
else
EscapeCommFunction(PortHandle,SETBREAK);
end;
procedure TComPort.RTS (State:Integer);
//RTS entweder auf 0 oder auf 1 setzen
begin
if State=0
then
EscapeCommFunction(PortHandle,CLRRTS)
else
EscapeCommFunction(PortHandle,SETRTS);
end;
procedure TComPort.DTR (State : integer);
//DTR entweder auf 0 oder 1 setzen
begin
if State = 0
then
EscapeCommFunction(PortHandle,CLRDTR)
else
EscapeCommFunction(PortHandle,SETDTR);
end;
function TComPort.CTS : Integer;
//CTS auf Status abfragen
var
mask : DWord;
begin
GetCommModemStatus(PortHandle,mask);
if (mask
and MS_CTS_ON) = 0
then
result := 0
else
result := 1;
end;
function TComPort.DSR : Integer;
// DSR auf Status abfragen
var
mask : DWord;
begin
GetCommModemStatus(PortHandle,mask);
if (mask
and MS_DSR_ON) = 0
then
result := 0
else
result := 1;
end;
function TComPort.RI : Integer;
// RI auf Status abfragen
var
mask : DWord;
begin
GetCommModemStatus(PortHandle,mask);
if (mask
and MS_RING_ON) = 0
then
result := 0
else
result := 1;
end;
function TComPort.DCD : Integer;
// DCD auf Status abfragen
var
mask : DWord;
begin
GetCommModemStatus(PortHandle,mask);
if (mask
and MS_RLSD_ON) = 0
then
result := 0
else
result := 1;
end;
function TComPort.Inputs : Integer;
var
mask : DWord;
begin
GetCommModemStatus(PortHandle,mask);
result := (mask
div 16)
and 15;
end;
function TComPort.GetHndl : integer;
begin
result := PortHandle;
end;
procedure TComPort.SetParity (Parity : byte);
begin
if (PortHandle > 0)
and (Parity
in [0..4])
then
begin
GetDCB;
DCB.Parity := Parity;
windows.SetCommState(PortHandle,DCB)
end;
end;
function TComport.GetParity : byte;
var
temp : TDCB;
begin
if (PortHandle > 0)
then
begin
GetCommState(PortHandle,temp);
result := temp.Parity;
end
else
result := 255;
end;
function TComport.GetBaudrate : Word;
var
temp : TDCB;
begin
if (PortHandle > 0)
then
begin
GetCommState(PortHandle,temp);
result := temp.BaudRate;
end
else
result := 0;
end;
procedure TComPort.SetBaudRate(Baudrate : Word);
begin
if (PortHandle > 0)
then
begin
GetCommState(PortHandle,DCB);
DCB.BaudRate := Baudrate;
SetCommState(PortHandle,DCB)
end;
end;
function TComPort.GetFlags : Integer;
var
temp : TDCB;
begin
if (PortHandle > 0)
then
begin
GetCommState(PortHandle,temp);
result := temp.Flags;
end
else
result := -1;
end;
function TComport.GetStopBits : byte;
var
temp : TDCB;
begin
if (PortHandle > 0)
then
begin
GetCommState(PortHandle,temp);
result := temp.StopBits;
end
else
result := 255;
end;
procedure TComport.SetStopBits(bits : byte);
begin
if (bits > 0)
and (bits <= 2)
then // Der gültige Eingabebereich wird festgelegt
begin
GetDCB;
DCB.StopBits := bits;
SetCommState (PortHandle,DCB);
end;
end;
function TComport.GetByteSize : byte;
var
temp : TDCB;
begin
GetCommState(PortHandle,temp);
result := temp.ByteSize;
end;
procedure TComport.SetByteSize(bytesize : byte);
begin
if bytesize
in [1..8]
then
begin
GetDCB;
DCB.ByteSize := bytesize;
SetCommState (PortHandle,DCB);
end;
end;
procedure TComport.BufferSize(Size : Integer);
//Sende -und Empfangspuffer setzen
begin
SetupComm(PortHandle,Size,Size);
end;
function TComport.CharInTXBuffer : Cardinal;
// Zeigt die aktuele Anzahl an Bytes im Sendepuffer an.
var
Comstat : _Comstat;
Errors : DWord;
begin
if windows.ClearCommError(PortHandle,Errors,@Comstat)
then
result := Comstat.cbOutQue
else result := 0;
end;
function TComport.CharInRXBuffer : Cardinal;
// Zeigt die aktuelle Anzahl an Bytes im Sendepuffer an.
var
Comstat : _Comstat;
Errors : DWord;
begin
if windows.ClearCommError(PortHandle,Errors,@Comstat)
then
result := Comstat.cbInQue
else result := 0;
end;
procedure TComport.ClearBuffer;
// Alle Puffer sofort leeren. Alle noch zu sendenden bzw zu empfangenden Zeichen gehen verloren!
begin
windows.PurgeComm(PortHandle,PURGE_TXCLEAR);
windows.PurgeComm(PortHandle,PURGE_RXCLEAR);
end;
procedure TComport.SENDBYTE (Dat: Integer);
// Ein einzelnes Byte (binär codiert) senden
var BytesWritten: DWord;
begin
WriteFile(PortHandle,Dat,1,BytesWritten,
NIL);
END;
function TComport.READBYTE(): Integer;
// Einen einzelnes Byte (binär codiert) empfangen
var Dat: Byte;
BytesRead: DWORD;
begin
ReadFile(PortHandle,Dat,1,BytesRead,
NIL);
if BytesRead = 1
then Result:=Dat
else Result := -1;
end;
procedure TComport.SENDSTRING (Buffer: Pchar);
// Einen Character senden.
var BytesWritten: DWord;
begin
WriteFile(PortHandle,Buffer^,Length(Buffer),BytesWritten,
NIL);
END;
function TComport.READSTRING(): Pchar;
// Einen Character empfangen
var Dat: Integer;
Data:
STRING;
begin
Dat := 0;
while ((Dat > -1)
and (Dat <> 13))
do begin
Dat := ReadByte();
if ((Dat > -1)
and (Dat <> 13))
then Data := Data + Chr(Dat);
end;
result := pchar(Data);
end;
destructor TComport.Destroy;
begin
if PortHandle > 0
then
CloseCom;
inherited;
end;
procedure Tcomport.Timeouts (TOut : Integer);
// Setzen der Sendetimeouts
var
Timeout : TCommTimeOuts;
begin
TimeOut.ReadIntervalTimeout := 1;
TimeOut.ReadTotalTimeoutMultiplier := 1;
TimeOut.ReadTotalTimeoutConstant := TOut;
TimeOut.WriteTotalTimeoutMultiplier := 10;
TimeOut.WriteTotalTimeoutConstant := TOut;
SetCommTImeouts(PortHandle,Timeout);
end;
procedure TComport.GetDCB;
begin
GetCommState(PortHandle,DCB);
end;
function TComport.SetFlags (Flag : Integer; Enable : Boolean) : boolean;
// Setzt spezielle Einstellungen des Ports
begin
GetDCB;
if Enable
then
DCB.Flags := DCB.Flags
or Flag
else
DCB.Flags := DCB.Flags
and (
not Flag);
result := Boolean(SetCommState(PortHandle,DCB));
end;
function TComport.GetStatusReport :
String;
var
Str :
String;
begin
Str := '
Baudrate von COM1: ' + IntToStr(Baudrate);
//Str := Str + chr(13) + 'Parität von COM1: ' + parity[Parity];
Str := Str + chr(13) + '
Flags von COM1: ' + IntToStr(GetFlags);
Str := Str + chr(13) + '
Bits/Byte von COM1: ' + IntToStr(ByteSize);
//Str := Str + chr(13) + 'Stopbits von COM1: ' + stopbits[StopBits];
Str := Str + chr(13) + '
Zeichen im RX-Puffer: ' + IntToStr(CharInRXBuffer);
Str := Str + chr(13) + '
Zeichen im TX-Puffer: ' + IntToStr(CharInTXBuffer);
result := Str;
end;
end.
Sprachen und Entwicklungsumgebungen
Antwort
4. Okt 2007, 16:36
http://www.linuxfocus.org/Deutsch/Ja...ticle186.shtml
Zitat
Zitat von DoktorD:
delphi AND GetcommState AND Createfile
Linear-Darstellung
