Attribute VB_Name = "Modul1"
Declare Sub OPENCOM Lib "RSAPI.DLL" (ByVal A$)
Declare Sub CLOSECOM Lib "RSAPI.DLL" ()
Declare Sub TIMEOUT Lib "RSAPI.DLL" (ByVal ms%)
Declare Sub STRREAD Lib "RSAPI.DLL" (ByVal A$)
Declare Sub STRLENGTH Lib "RSAPI.DLL" (ByVal L%)
Declare Sub TIMEINIT Lib "RSAPI.DLL" ()
Declare Function TIMEREAD Lib "RSAPI.DLL" () As Long
Declare Sub SENDBYTE Lib "RSAPI.DLL" (ByVal B%)
Declare Function SENDSTRING Lib "RSAPI.DLL" (ByVal S As String) As Integer
Declare Function READBYTE Lib "RSAPI.DLL" () As Integer
Declare Sub DELAY Lib "RSAPI.DLL" (ByVal ms%)
 Declare Sub DTR Lib "RSAPI.DLL" (Pegel As Integer)
 Declare Sub RTS Lib "RSAPI.DLL" (Pegel As Integer)
 Declare Sub TXD Lib "RSAPI.DLL" (Pegel As Integer)
 Declare Function CTS Lib "RSAPI.DLL" () As Integer
Sub Main()
Call Blatt_kw 'Eventuell neues Blatt anlegen
offset1 = 53 'StartZeile definieren
 'Bis zum letzen Eintrag fahren
 j = 0
 While (Cells(j + offset1, 1) = "M" Or Cells(j + offset1, 1) = "A")
    j = j + 1
 Wend
 ' Werte erfassen
 While Not KeyCode
      OPENCOM "COM1:9600,n,8,2" ' Hier müssen die richtigen Parameter der Schnittstelle stehen
      TIMEOUT 400
      RTS 1 ' Notwendig, damit ein öffnen der Tür erkannt wird
      DELAY 100
      If CTS = 1 Then   ' Automatische Messung Prüfstandstür ist geschlossen
        Cells(j + offset1, 1) = "A"
      Else 'Prüfstandstüre offen manuelle Messung
        Cells(j + offset1, 1) = "M"
      End If
      messwert = Einezeile() 'Eine Zeile mit neuen Messwerten einlesen
      ' Zerlegung der Messwerte (dies ist ganz spezifisch und muß individuell angepasst werden)
      Cells(j + offset1, 2) = Date ' Datum der Messung
      Cells(j + offset1, 3) = Time ' Zeitstempel der Messung
      Cells(j + offset1, 4) = Val(Mid(messwert, 2, 2)) 'Prüfprogrammstring "ausschneiden"
      Cells(j + offset1, 5) = Mid(messwert, 8, 2) 'Ergebnisstring  (PB=i.O.) "ausschneiden"
      Cells(j + offset1, 6) = Val(Mid(messwert, 12, 7)) 'Messwertstring ausschneiden und umwandeln in einen Wert
      Cells(j + offset1, 7) = Mid(messwert, 20, 3) 'Einheit (kPa)
      ' Chargen eintragen
      For L = 0 To 11
        Cells(j + offset1, 8 + L) = Cells(2 + L, 12)
      Next L
      ' Messwerte in t- Zeile eintragen
      t = 43 '
      For L = 1 To 22
        Cells(t, L) = Cells(j + offset1, L)
      Next L
      
      j = j + 1 ' Nächste j
 
      RTS 0 ' Notwendig, damit ein öffnen der Tür erkannt wird
      CLOSECOM 'Schnittstelle schließen
      If j / 10 = Int(j / 10) Then ActiveWorkbook.Save ' Speichern nach 10 Messungen
  Wend
 CLOSECOM

End Sub


Function Einezeile() As String
' Liest eine Zeile mit Daten von der seriellen Schnittstelle ein und wandelt alle Byts, die höher als 128 sind um.
Alt$ = ""
K = 1
While True
    e = READBYTE ' Byte einlesen
    DELAY 10
    ' Blinkender Zähler zeigt, daß Messung Aktiv ist
    If Cells(7, 14) = K Then Cells(7, 14) = " Messung aktiv " Else Cells(7, 14) = K
             K = K + 1
    If e > 127 Then e = e - 128 ' Nur die unteren 128 Zeichen werden benutzt
    If e > -1 Then
        A$ = Chr$(e)
        Alt$ = Alt$ + A$ ' String zusammenbauen
    End If
    If e = -1 And Alt$ <> "" Then
    Einezeile = Alt$
    Exit Function
    End If
        If Len(Alt$) > 255 Then Alt$ = " " 'Absicherung gegen Überlauf
Wend
End Function
Sub Blatt_kw()
    gefunden = 0
    For i = 1 To Sheets.Count
        If "KW" & Str$(DatePart("ww", Date - 7)) = Sheets(i).Name Then gefunden = 1
    Next i
    If gefunden = 0 Then
       ' Arbeitsblatt hinzufügen
      Sheets("Muster").Select
      ActiveWorkbook.Sheets.Copy after:=Worksheets(Worksheets.Count)
      Sheets("Muster (2)").Activate
       Sheets("Muster (2)").Name = "KW" & Str$(DatePart("ww", Date - 7))
    Else 'Arbeitsblatt ist vorhanden
        Sheets("KW" & Str$(DatePart("ww", Date - 7))).Activate 'aktivieren
    End If
End Sub
Sub test_schalter()
While Not esc
      OPENCOM "COM1:9600,n,8,2"
      RTS 1 ' Notwendig, damit ein öffnen der Tür erkannt wird
      DELAY 100
      If CTS = 1 Then   ' Automatische Messung Prüfstandstür ist geschlossen
        Cells(2, 1) = "A"
      Else 'Prüfstandstüre offen
        Cells(2, 1) = "M"
      End If
CLOSECOM
Wend
End Sub