Datenübertragung mit der Seriellen Schnittstelle

Wie schon bei Beispiel 29 wird ein Com-Port nur mit API-Funktionen des Betriebssystems geöffnet. Spezielle Steuerelemente und dll's sind unnötig. Die Übertragung läuft im Prinzip so wie ein Dateizugriff ab. Mit CreateFile wird ein Comport geöffnet und mit WriteFile/ReadFile werden Daten gesendet und empfangen. Da ein Empfang von Daten nicht über ein Ereignis signalisiert wird, muss man halt häufiger mal nachschauen, ob im Puffer was angekommen ist.

Das Ganze habe ich als Klasse ausgeführt, um den Umgang damit zu erleichtern. Da bei der Datenübertragung häufig Ascii und nicht Ansi (Win) verwendet wird, sind auch ein paar Umwandlungsfunktionen dabei. Wenn man an der Seriellen Schnittstelle Pin 2 und 3 brückt, kann man Senden/Empfangen auch bequem austesten.
Ich habe mit Hyperterminal am Laptop als Gegenstelle getestet. Das mit der Baudrate funktioniert, auch die Ascii - Ansi Umwandlung. Das Setzen der Ausgänge DTR und RTS, sowie das korrekte Auslesen der Eingänge habe ich mit einem Schnittstellentester ausprobiert. Ein paar Sachen, wie XON, XOFF, Flussüberwachung etc. sind zwar umgesetzt, aber ungetestet.
  

Beispielmappe uebertragung.zip 87 KB)

'**************************************************
'Das Folgende zeigt die Verwendung der Klasse.
'Danach kommt die eigentliche Klasse
************************************************** 

Option Explicit
Private Komm As clsSeriell

Private Sub cbStatus_Click()
    If ObjPtr(Komm) <> 0 Then
        'Status Steuerleitungen abfragen
        chbCTS = Komm.CTS_Status
        chbDSR = Komm.DSR_Status
        chbRing = Komm.RING_Status
        chbRLS = Komm.DCD_Status
    End If
End Sub

Private Sub chbCTSOutFlow_Click()
    Range("C1").Select
    Einstellungen
End Sub
Private Sub chbDSROutFlow_Click()
    Range("C1").Select
    Einstellungen
End Sub
Private Sub chbDSRSensitiv_Click()
    Range("C1").Select
    Einstellungen
End Sub
Private Sub chbEmpfangAscii_Click()
    Range("C1").Select
    Einstellungen
End Sub
Private Sub chbNoEOFCheck_Click()
    Range("C1").Select
    Einstellungen
End Sub
Private Sub chbParityCheck_Click()
    Range("C1").Select
    Einstellungen
End Sub
Private Sub chbSendenAscii_Click()
    Range("C1").Select
    Einstellungen
End Sub
Private Sub chbXOffContinuesTx_Click()
    Range("C1").Select
    Einstellungen
End Sub
Private Sub chbXONIn_Click()
    Range("C1").Select
    Einstellungen
End Sub
Private Sub chbXONOut_Click()
    Range("C1").Select
    Einstellungen
End Sub

Private Sub chbCTS_Click()
    Range("C1").Select
End Sub
Private Sub chbDSR_Click()
    Range("C1").Select
End Sub
Private Sub chbRing_Click()
    Range("C1").Select
End Sub
Private Sub chbRLS_Click()
    Range("C1").Select
End Sub

Private Sub chbRTS_Click()
    If ObjPtr(Komm) <> 0 Then
        'RTS setzen
        Komm.RTS_Fest = chbRTS
    End If
    Range("C1").Select
End Sub
Private Sub chbDTR_Click()
    If ObjPtr(Komm) <> 0 Then
        'DTR setzen
        Komm.DTR_Fest = chbDTR
    End If
    Range("C1").Select
End Sub

Private Sub cmbcrlf_Click()
Range("A17") = Range("A17") & vbCrLf
End Sub
Private Sub cmbLf_Click()
    Range("A17") = Range("A17") & vbLf
End Sub
Private Sub cmbCr_Click()
    Range("A17") = Range("A17") & vbCr
End Sub

Private Sub cmbEmpfangen_Click()
Dim Wartezeit As Long, Puffer As String
Wartezeit = Range("B1")
If ObjPtr(Komm) <> 0 Then
    cbStatus_Click 'Steuerleitungen abfragen
    If chbEmpfangAscii.Value = True Then
        'Empfangener Text wird von Ascii nach
        'Ansi umgewandelt
        Komm.Eingang_ASCII = True
    Else
        'Empfangener Text bleibt unverändert
        Komm.Eingang_ASCII = False
    End If
    'Timeout für Warten auf Empfang (1-60 s)
    Komm.Timeout_Empfang = Wartezeit
    'Empfangenen Text auslesen
    Puffer = Komm.EingegangenerText
    If Puffer <> "" Then
        'Zur Zelle A21 in eine neue Zeile hinzufügen
        Range("A21") = Range("A21") & Puffer & Chr(10)
    End If
End If
End Sub

Private Sub cmbLoeschen_Click()
'Zelle, in der der Empfangene Text steht
    Range("A21") = ""
End Sub
Private Sub cmbSendefeldLoeschen_Click()
'Zelle, in der der Sendetext steht
    Range("A17") = ""
End Sub

Private Sub cmbSenden_Click()
If ObjPtr(Komm) <> 0 Then
    cbStatus_Click 'Steuerleitungen abfragen
    If chbSendenAscii.Value = True Then
        'Zu sendender Ansi-Text wird nach Ascii umgewandelt
        Komm.Ausgabe_ASCII = True
    Else
        'Zu sendender Ansi-Text wird nicht umgewandelt
        Komm.Ausgabe_ASCII = False
    End If
    Komm.Ausgabetext = Range("A17")
End If
End Sub

Private Sub Einstellungen()
If ObjPtr(Komm) <> 0 Then
    With Komm
        'Einstellung Kommunikationsschnittstelle
        .Baudrate = 1200
        .Datenbits = 8
        'Parity : 4=Leerzeichen / 3=Markierung
        '2=gerade / 1=ungerade / 0=keine
        .Parity = 0
        'Stopbits : 2=2 / 1=1,5 / 0=1
        .Stopbits = 0
        'Einstellungen Zeichensatzumwandlung der
        'Klasse übergeben
        .Eingang_ASCII = chbEmpfangAscii
        .Ausgabe_ASCII = chbSendenAscii
        'Einstellungen Komm
        .CTSOutFlowControl = chbCTSOutFlow
        .DSROutFlowControl = chbDSROutFlow
        .DSRSensitiv = chbDSRSensitiv
        .NoEOFCheck = chbNoEOFCheck
        .ParityCheck = chbParityCheck
        .XOFFCHAR = Range("B10")
        .XONCHAR = Range("B11")
        .XOffContinuesTx = chbXOffContinuesTx
        .XONInFlowControl = chbXONIn
        .XONOutFlowControl = chbXONOut
        .Baudrate = Range("B9")
        .Datenbits = Range("B7")
        .Parity = Range("B6")
        .Stopbits = Range("B8")
        .LängeEingabepuffer = Range("B5")
        .LängeAusgabepuffer = Range("B5")
    End With
End If
End Sub

Private Sub cmbOeffnen_Click()
Dim hwndCom As Long
'Neue Klasse clsSeriell
Set Komm = New clsSeriell
With Komm
    Einstellungen
    'Com-Port öffnen
    hwndCom = .KommunikationÖffnen(Range("B2"))
    If hwndCom <> 0 Then
        .RTS_Fest = chbRTS
        .DTR_Fest = chbDTR
        cbStatus_Click 'Steuerleitungen abfragen
        Me.Unprotect
            'Zustand farbig darstellen
            Range("B3").Interior.Color = vbRed
            Range("B4").Interior.ColorIndex = xlNone
            Range("B12") = hwndCom
        Me.Protect
    End If
End With
End Sub

Private Sub cmbSchliessen_Click()
On Error Resume Next
If ObjPtr(Komm) <> 0 Then
    'Com-Port schließen
    Komm.KommunikationSchließen
End If
Me.Unprotect
    'Zustand farbig darstellen
    Range("B4").Interior.Color = vbRed
    Range("B3").Interior.ColorIndex = xlNone
    Range("B12") = ""
Me.Protect
Set Komm = Nothing
End Sub

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
 If Target.Column <> 2 Then Exit Sub
 If (Target.Row < 5) Or (Target.Row > 11) Then Exit Sub
 Einstellungen
End Sub

'**************************************************
'Ab hier beginnt die Klasse clsSeriell
************************************************** 

Option Explicit

' fBitFields
' FieldName             Bit #     Description
' -----------------     -----     ------------------------------
' fBinary                 1       binary mode, no EOF check
' fParity                 2       enable parity checking
' fOutxCtsFlow            3       CTS output flow control
' fOutxDsrFlow            4       DSR output flow control
' fDtrControl             5       DTR flow control type (2 bits)
' fDsrSensitivity         7       DSR sensitivity
' fTXContinueOnXoff       8       XOFF continues Tx
' fOutX                   9       XON/XOFF out flow control
' fInX                   10       XON/XOFF in flow control
' fErrorChar             11       enable error replacement
' fNull                  12       enable null stripping
' fRtsControl            13       RTS flow control (2 bits)
' fAbortOnError          15       abort reads/writes on error
' fDummy2                16       reserved
Private Type DCB
        DCBlength As Long
        Baudrate As Long
        fBitFields As Long
        wReserved As Integer
        XonLim As Integer
        XoffLim As Integer
        ByteSize As Byte
        Parity As Byte
        Stopbits As Byte
        XonChar As Byte
        XoffChar As Byte
        ErrorChar As Byte
        EofChar As Byte
        EvtChar As Byte
        wReserved1 As Integer
End Type
Private Type COMSTAT
    Bits As Long
    cbInQue As Long
    cbOutQue As Long
End Type
Private Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
End Type
Private Declare Function CharToOem Lib "user32" Alias _
    "CharToOemA" ( _
    ByVal lpszSrc As String, _
    ByVal lpszDst As String _
    ) As Long
Private Declare Function OemToChar Lib "user32" Alias _
    "OemToCharA" ( _
    ByVal lpszSrc As String, _
    ByVal lpszDst As String _
    ) As Long
Private Declare Function CreateFile Lib "kernel32" Alias _
    "CreateFileA" ( _
    ByVal lpFileName As String, _
    ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, _
    lpSecurityAttributes As SECURITY_ATTRIBUTES, _
    ByVal dwCreationDisposition As Long, _
    ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As Long _
    ) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As Long _
    ) As Long
Private Declare Function SetCommBreak Lib "kernel32" ( _
    ByVal nCid As Long _
    ) As Long
Private Declare Function ClearCommBreak Lib "kernel32" ( _
    ByVal nCid As Long _
    ) As Long
Private Declare Function EscapeCommFunction& Lib "kernel32" _
    (ByVal nCid As Long, ByVal nFunc As Long)
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function GetCommModemStatus& Lib "kernel32" ( _
    ByVal hFile As Long, _
    lpModemStat As Long)
Private Declare Function ReadFile Lib "kernel32" ( _
    ByVal hFile As Long, _
    ByVal lpBuffer As String, _
    ByVal nNumberOfBytesToRead As Long, _
    lpNumberOfBytesRead As Long, _
    ByVal NOlpOverlapped As Long _
    ) As Long
Private Declare Function WriteFile Lib "kernel32" ( _
    ByVal hFile As Long, _
    ByVal lpBuffer As String, _
    ByVal nNumberOfBytesToWrite As Long, _
    lpNumberOfBytesWritten As Long, _
    ByVal lpOverlapped As Long _
    ) As Long
Private Declare Function SetupComm Lib "kernel32" ( _
    ByVal hFile As Long, _
    ByVal dwInQueue As Long, _
    ByVal dwOutQueue As Long _
    ) As Long
Private Declare Function ClearCommError Lib "kernel32" ( _
    ByVal hFile As Long, _
    lpErrors As Long, _
    lpStat As COMSTAT _
    ) As Long
Private Declare Function SetCommState Lib "kernel32" ( _
    ByVal hCommDev As Long, _
    lpDCB As DCB _
    ) As Long
Private Declare Function GetCommState Lib "kernel32" ( _
    ByVal nCid As Long, _
    lpDCB As DCB _
    ) As Long
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const SETDTR = 5
Private Const SETRTS = 3
Private Const CLRDTR = 6
Private Const CLRRTS = 4
Private Const MS_DSR_ON = &H20&
Private Const MS_CTS_ON = &H10&
Private Const MS_RING_ON = &H40&
Private Const MS_RLSD_ON = &H80&
Private iEingabepuffer As Long, iAusgabepuffer As Long
Private iAusgabe_ASCII As Boolean, iEingang_ASCII As Boolean
Private ComHandle As Long, iWartezeit As Long
Private iBaudrate As Long, iDatenbits As Long
Private iStopbits As Long, iParity As Long
Private iXONCHAR As String, iXOFFCHAR As String
Private iCTSOutFlowControl As Boolean, iDSROutFlowControl As Boolean 'Bit 3, Bit 4
Private iXONOutFlowControl As Boolean, iXONInFlowControl As Boolean 'Bit 9, Bit 10
Private iParityCheck As Boolean, iNoEOFCheck As Boolean 'Bit 2, Bit 1
Private iDSRSensitiv As Boolean, iXOffContinuesTx As Boolean 'Bit 7, Bit 8

 
Private Function DTR(DTRAN As Boolean) As Boolean
'Steuerleitung DTR setzen
'DTR (Data Terminal Ready), Pin 4
Dim Fehler&
If DTRAN Then
    Fehler = EscapeCommFunction(ComHandle, SETDTR)
Else
    Fehler = EscapeCommFunction(ComHandle, CLRDTR)
End If
If Fehler <> 0 Then DTR = True
End Function
Private Function RTS(RTSAN As Boolean) As Boolean
'Steuerleitung RTS setzen
'RTS (Request To Send), Pin 7
Dim Fehler&
If RTSAN Then
    Fehler = EscapeCommFunction(ComHandle, SETRTS)
Else
    Fehler = EscapeCommFunction(ComHandle, CLRRTS)
End If
If Fehler <> 0 Then RTS = True
End Function
Private Function TXD(TXDAN As Boolean) As Boolean
'Sendeleitung Dauer High
'TXD (Transmit Data). Sendeleitung, Pin 3
Dim Fehler&
If TXDAN Then
    Fehler = SetCommBreak(ComHandle)
Else
    Fehler = ClearCommBreak(ComHandle)
End If
If Fehler <> 0 Then TXD = True
End Function
Private Function DCDstatus() As Boolean
'Status DCD
'DCD (Data Carrier Detect), Pin 1
Dim Status&
GetCommModemStatus ComHandle, Status
If Status And MS_RLSD_ON Then
    DCDstatus = True
Else
    DCDstatus = False
End If
End Function
Private Function RINGstatus() As Boolean
Dim Status&
GetCommModemStatus ComHandle, Status
If Status And MS_RING_ON Then
    RINGstatus = True
Else
    RINGstatus = False
End If
End Function
Private Function CTSstatus() As Boolean
Dim Status&
GetCommModemStatus ComHandle, Status
If Status And MS_CTS_ON Then
    CTSstatus = True
Else
    CTSstatus = False
End If
End Function
Private Function DSRstatus() As Boolean
'Status DSR
'DSR (Data Set Ready), Pin 6
Dim Status&
GetCommModemStatus ComHandle, Status
If Status And MS_DSR_ON Then
    DSRstatus = True
Else
    DSRstatus = False
End If
End Function

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'DTR Fest auf Ein
Public Property Let DTR_Fest(ByVal vNewValue As Boolean)
    DTR vNewValue
End Property

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'RTS Fest auf Ein
Public Property Let RTS_Fest(ByVal vNewValue As Boolean)
    RTS vNewValue
End Property

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'TXD Fest auf Ein
Public Property Let TXD_Fest(ByVal vNewValue As Boolean)
    TXD vNewValue
End Property

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Status Eingänge
Public Property Get DCD_Status() As Boolean
    DCD_Status = DCDstatus()
End Property
Public Property Get RING_Status() As Boolean
    RING_Status = RINGstatus()
End Property
Public Property Get CTS_Status() As Boolean
    CTS_Status = CTSstatus()
End Property
Public Property Get DSR_Status() As Boolean
    DSR_Status = DSRstatus()
End Property

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Puffergröße für Ein- und Ausgabe
Public Property Let LängeEingabepuffer(ByVal vNewValue As Long)
    iEingabepuffer = vNewValue
    KommunikationEinstellen
End Property
Public Property Get LängeEingabepuffer() As Long
    LängeEingabepuffer = iEingabepuffer
End Property
Public Property Let LängeAusgabepuffer(ByVal vNewValue As Long)
    iAusgabepuffer = vNewValue
    KommunikationEinstellen
End Property
Public Property Get LängeAusgabepuffer() As Long
    LängeAusgabepuffer = iAusgabepuffer
End Property

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Baudrate, Datenbits, Stopbits, Parity
Public Property Let Baudrate(ByVal vNewValue As Long)
    iBaudrate = vNewValue
    KommunikationEinstellen
End Property
Public Property Get Baudrate() As Long
    Baudrate = iBaudrate
End Property
Public Property Let Datenbits(ByVal vNewValue As Long)
    iDatenbits = vNewValue
    KommunikationEinstellen
End Property
Public Property Get Datenbits() As Long
    Datenbits = iDatenbits
End Property
Public Property Let Stopbits(ByVal vNewValue As Long)
    iStopbits = vNewValue
    KommunikationEinstellen
End Property
Public Property Get Stopbits() As Long
    Stopbits = iStopbits
End Property
Public Property Let Parity(ByVal vNewValue As Long)
    iParity = vNewValue
    KommunikationEinstellen
End Property
Public Property Get Parity() As Long
    Parity = iParity
End Property
Public Property Let XONCHAR(ByVal vNewValue As String)
    iXONCHAR = Left(vNewValue, 1)
    KommunikationEinstellen
End Property
Public Property Get XONCHAR() As String
    XONCHAR = iXONCHAR
End Property
Public Property Let XOFFCHAR(ByVal vNewValue As String)
    iXOFFCHAR = Left(vNewValue, 1)
    KommunikationEinstellen
End Property
Public Property Get XOFFCHAR() As String
    XOFFCHAR = iXOFFCHAR
End Property
Public Property Let CTSOutFlowControl(ByVal vNewValue As Boolean)
    iCTSOutFlowControl = vNewValue
    KommunikationEinstellen
End Property
Public Property Get CTSOutFlowControl() As Boolean
    CTSOutFlowControl = iCTSOutFlowControl
End Property
Public Property Let DSROutFlowControl(ByVal vNewValue As Boolean)
    iDSROutFlowControl = vNewValue
    KommunikationEinstellen
End Property
Public Property Get DSROutFlowControl() As Boolean
    DSROutFlowControl = iDSROutFlowControl
End Property
Public Property Let XONOutFlowControl(ByVal vNewValue As Boolean)
    iXONOutFlowControl = vNewValue
    KommunikationEinstellen
End Property
Public Property Get XONOutFlowControl() As Boolean
    XONOutFlowControl = iXONOutFlowControl
End Property
Public Property Let XONInFlowControl(ByVal vNewValue As Boolean)
    iXONInFlowControl = vNewValue
    KommunikationEinstellen
End Property
Public Property Get XONInFlowControl() As Boolean
    XONInFlowControl = iXONInFlowControl
End Property
Public Property Let ParityCheck(ByVal vNewValue As Boolean)
    iParityCheck = vNewValue
    KommunikationEinstellen
End Property
Public Property Get ParityCheck() As Boolean
    ParityCheck = iParityCheck
End Property
Public Property Let NoEOFCheck(ByVal vNewValue As Boolean)
    iNoEOFCheck = vNewValue
    KommunikationEinstellen
End Property
Public Property Get NoEOFCheck() As Boolean
    NoEOFCheck = iNoEOFCheck
End Property
Public Property Let DSRSensitiv(ByVal vNewValue As Boolean)
    iDSRSensitiv = vNewValue
    KommunikationEinstellen
End Property
Public Property Get DSRSensitiv() As Boolean
    DSRSensitiv = iDSRSensitiv
End Property
Public Property Let XOffContinuesTx(ByVal vNewValue As Boolean)
    iXOffContinuesTx = vNewValue
    KommunikationEinstellen
End Property
Public Property Get XOffContinuesTx() As Boolean
    XOffContinuesTx = iXOffContinuesTx
End Property

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Wenn Ausgabe_ASCII Wahr, wird der Gesendete Text von Ansi
'nach Ascii umgewandelt, ansonsten wird unverändert gesendet
Public Property Let Ausgabe_ASCII(ByVal vNewValue As Boolean)
    iAusgabe_ASCII = vNewValue
End Property
Public Property Get Ausgabe_ASCII() As Boolean
    Ausgabe_ASCII = iAusgabe_ASCII
End Property

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Timeout Empfang
Public Property Let Timeout_Empfang(ByVal vNewValue As Long)
    If iWartezeit <= 0 Then iWartezeit = 1
    If iWartezeit >= 60 Then iWartezeit = 60
    iWartezeit = vNewValue
End Property
Public Property Get Timeout_Empfang() As Long
    Timeout_Empfang = iWartezeit
End Property

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Wenn Eingang_ASCII Wahr, wird der Eingegangene Text von Ascii
' nach Ansi umgewandelt, ansonsten wird unverändert gesendet
Public Property Let Eingang_ASCII(ByVal vNewValue As Boolean)
    iEingang_ASCII = vNewValue
End Property
Public Property Get Eingang_ASCII() As Boolean
    Eingang_ASCII = iEingang_ASCII
End Property

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Text für Ausgabe
'Wenn iAusgabe_ASCII Wahr, wird der Text von Ansi nach
'Ascii umgewandelt, ansonsten wird unverändert gesendet
Public Property Let Ausgabetext(ByVal vNewValue As String)
If iAusgabe_ASCII Then
    Senden NachAscii(vNewValue)
Else
    Senden vNewValue
End If
End Property

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Eingegangener Text
'Wenn iEingang_ASCII Wahr, wird der Text von Ascii nach
'Ansi umgewandelt, ansonsten wird unverändert empfangen
Public Property Get EingegangenerText() As String
If iEingang_ASCII Then
    EingegangenerText = NachAnsi(Empfangen())
Else
    EingegangenerText = Empfangen()
End If
End Property

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Daten auslesen und Senden
Private Function Empfangen()
Dim ret As Long, Puffer As String, geschrieben As Long
Dim gebraucht As Long, comerror As Long
Dim Status As COMSTAT, TimeoutWaitForInput As Date
'Beenden, wenn schon ein Port offen ist
If ComHandle = 0 Then Exit Function
'Timeoutüberprüfung Empfang
If iWartezeit <= 0 Then iWartezeit = 1
If iWartezeit >= 60 Then iWartezeit = 60
'Zu diesem Zeitpunkt wird spätestens abgebrochen
TimeoutWaitForInput = Now + TimeSerial(0, 0, iWartezeit)
Do
    'Nachschauen, ob was eingegangen ist
    ClearCommError ComHandle, comerror, Status
    'Anzahl der Zeichen im Einganspuffer ermitteln
    gebraucht = Status.cbInQue
    If gebraucht > 0 Then
        'Puffer auslesen
        Puffer = String(gebraucht, 0)
        ReadFile ComHandle, Puffer, gebraucht, geschrieben, 0
        Exit Do
    End If
    'Beenden, wenn Zeit abgelaufen ist
    If Now > TimeoutWaitForInput Then Exit Do
Loop While gebraucht = 0
Empfangen = Puffer
End Function

Private Function Senden(Text As String)
Dim geschrieben As Long
'Beenden, wenn kein Port offen
If ComHandle = 0 Then Exit Function
'Text in den Ausgabepuffer schieben
WriteFile ComHandle, Text, Len(Text), geschrieben, 0
End Function

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Kommunikation Öffnen und schließen
'Comport als Text übergeben z.B. com1, com2 etc. ..
Public Function KommunikationSchließen() As Boolean
    KommunikationSchließen = CloseHandle(ComHandle) <> 0
    ComHandle = 0
End Function

Public Function KommunikationÖffnen(Optional Port As String) As Long
Dim Sicherheit As SECURITY_ATTRIBUTES
Dim Zugriff As Long, Fehler As Long
Dim Einstellungen As DCB
Dim Flags As Long, Korr As Integer
On Error GoTo fehlerbehandlung
Zugriff = GENERIC_READ Or GENERIC_WRITE
If Port = "" Then Port = "COM1"
Sicherheit.nLength = 12
Sicherheit.bInheritHandle = 0
Sicherheit.lpSecurityDescriptor = 0
Fehler = GetLastError
If ComHandle <> 0 Then GoTo fehlerbehandlung
'Com öffnen
ComHandle = CreateFile(Port, Zugriff, 0&, Sicherheit, _
    OPEN_EXISTING, 0&, 0&)
'Einstellung setzen
KommunikationEinstellen
fehlerbehandlung:
KommunikationÖffnen = ComHandle
End Function

Private Sub KommunikationEinstellen()
Dim Einstellungen As DCB
Dim Flags As Long, Korr As Integer
If ComHandle = 0 Then Exit Sub
'Datenbits
If (iDatenbits < 5) Or (iDatenbits > 8) Then iDatenbits = 8
'Baudrate
Select Case iBaudrate
    Case 110, 300, 1200, 2400, 4800, 9600
    Case 19200, 38400, 57600, 115200
    Case Else
        iBaudrate = 9600
End Select
'Stopbits
Select Case iStopbits
    Case 2
        iStopbits = 2
    Case 1.5
        iStopbits = 1
    Case Else
        iStopbits = 0
End Select
'Parity : 4=Leerzeichen / 3=Markierung
'2=gerade / 1=ungerade / 0=keine
If (iParity > 4) Or (iParity < 0) Then iParity = 0
'GetCommState ComHandle, Einstellungen
With Einstellungen
    .ByteSize = iDatenbits
    .Parity = iParity
    .Baudrate = iBaudrate
    .Stopbits = iStopbits
    .XONCHAR = Asc(iXONCHAR)
    .XOFFCHAR = Asc(iXOFFCHAR)
    'Anscheinend fängt beim Kommentar in der Win32Api.txt die
    'Zählung der Bits bei 1 an. Ich bin mir aber nicht sicher,
    'deshalb Kurrektur vorgesehen.
    'Bei 1. Bit Zählung = 1,  korr=1
    'Bei 1. Bit Zählung = 0,  korr=0
    Korr = 1
    '-----------
    Flags = 2 ^ (3 - Korr)
    If iCTSOutFlowControl Then
        .fBitFields = .fBitFields Or Flags
    Else
        .fBitFields = .fBitFields And (Not Flags)
    End If
    '-----------
    Flags = 2 ^ (4 - Korr)
    If iDSROutFlowControl Then
        .fBitFields = .fBitFields Or Flags
    Else
        .fBitFields = .fBitFields And (Not Flags)
    End If
    '-----------
    Flags = 2 ^ (9 - Korr)
    If iXONOutFlowControl Then
        .fBitFields = .fBitFields Or Flags
    Else
        .fBitFields = .fBitFields And (Not Flags)
    End If
    '-----------
    Flags = 2 ^ (10 - Korr)
    If iXONInFlowControl Then
        .fBitFields = .fBitFields Or Flags
    Else
        .fBitFields = .fBitFields And (Not Flags)
    End If
    '-----------
    Flags = 2 ^ (2 - Korr)
    If iParityCheck Then
        .fBitFields = .fBitFields Or Flags
    Else
        .fBitFields = .fBitFields And (Not Flags)
    End If
    '-----------
    Flags = 2 ^ (1 - Korr)
    If iNoEOFCheck Then
        .fBitFields = .fBitFields Or Flags
    Else
        .fBitFields = .fBitFields And (Not Flags)
    End If
    '-----------
    Flags = 2 ^ (7 - Korr)
    If iDSRSensitiv Then
        .fBitFields = .fBitFields Or Flags
    Else
        .fBitFields = .fBitFields And (Not Flags)
    End If
    '-----------
    Flags = 2 ^ (8 - Korr)
    If iXOffContinuesTx Then
        .fBitFields = .fBitFields Or Flags
    Else
        .fBitFields = .fBitFields And (Not Flags)
    End If
End With
'Com-Einstellungen setzen
SetCommState ComHandle, Einstellungen
'Puffer setzen
If iEingabepuffer = 0 Then iEingabepuffer = 4096
If iAusgabepuffer = 0 Then iAusgabepuffer = 4096
SetupComm ComHandle, iEingabepuffer, iAusgabepuffer
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Umwandlungsfunktionen
Public Function NachAnsi(ByVal Quelle As String) As String
Dim Zielzeichenkette$, dummy&
Zielzeichenkette = String(Len(Quelle), 0)
dummy = OemToChar(Quelle, Zielzeichenkette)
NachAnsi = Zielzeichenkette
End Function
Public Function NachAscii(ByVal Quelle As String) As String
Dim Zielzeichenkette$, dummy&
Zielzeichenkette = String(Len(Quelle), 0)
dummy = CharToOem(Quelle, Zielzeichenkette)
NachAscii = Zielzeichenkette
End Function

Private Sub Class_Terminate()
    KommunikationSchließen
End Sub
Public Sub AllePortsSchließen()
Dim i As Long
Do
    i = i + 1
    If i > 1000000 Then Exit Do
Loop While CloseHandle(i) = 0
ComHandle = 0
End Sub