From 13af675f50de436d9c7a0eedd407d5550b669246 Mon Sep 17 00:00:00 2001 From: clawdia Date: Wed, 22 Jul 2026 12:00:56 +0200 Subject: [PATCH] Add RSAPI.DLL-free VBA module for MP30 device --- Modul1_RSAPI_Free.bas | 1211 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1211 insertions(+) create mode 100644 Modul1_RSAPI_Free.bas diff --git a/Modul1_RSAPI_Free.bas b/Modul1_RSAPI_Free.bas new file mode 100644 index 0000000..cb26558 --- /dev/null +++ b/Modul1_RSAPI_Free.bas @@ -0,0 +1,1211 @@ +Attribute VB_Name = "Modul1" + +' ============================================================ +' RSAPI.FREIE — RSAPI.DLL-Unabhängige COM-Port Schnittstelle +' ============================================================ +' Verwendet Windows API (kernel32.dll) statt RSAPI.DLL +' Funktioniert mit allen modernen Excel-Versionen (32 & 64-bit) + +#If VBA7 Then + Private Declare PtrSafe Function CreateFile Lib "kernel32.dll" _ + (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _ + ByVal dwShareMode As Long, lpSecurityAttributes As Any, _ + ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _ + ByVal hTemplateFile As Long) As Long + + Private Declare PtrSafe Function WriteFile Lib "kernel32.dll" _ + (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, _ + lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long + + Private Declare PtrSafe Function ReadFile Lib "kernel32.dll" _ + (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, _ + lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long + + Private Declare PtrSafe Function CloseHandle Lib "kernel32.dll" _ + (ByVal hObject As Long) As Long + + Private Declare PtrSafe Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long) + + Private Declare PtrSafe Function SetCommTimeouts Lib "kernel32.dll" _ + (ByVal hFile As Long, lpCommTimeouts As Any) As Long + + Private Declare PtrSafe Function GetCommTimeouts Lib "kernel32.dll" _ + (ByVal hFile As Long, lpCommTimeouts As Any) As Long + + Private Declare PtrSafe Function SetupComm Lib "kernel32.dll" _ + (ByVal hFile As Long, ByVal dwInQueue As Long, ByVal dwOutQueue As Long) As Long + + ' DCB Struktur für Baudrate etc. + Private Type DCB + DCBlength As Long + BaudRate As Long + fBinary As Long + fParity As Long + fOutxCtsFlow As Long + fOutxDsrFlow As Long + fDtrControl As Long + fDsrSensitivity As Long + fTXContinueOnXoff As Long + fOutX As Long + fInX As Long + fErrorChar As Long + fNull As Long + fRtsControl As Long + fAbortOnError As Long + fDummy2 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 + End Type + + Private Declare PtrSafe Function BuildCommDCB Lib "kernel32.dll" Alias _ + "BuildCommDCBA" (ByVal lpDef As String, lpDCB As DCB) As Long + + Private Declare PtrSafe Function SetCommState Lib "kernel32.dll" _ + (ByVal hFile As Long, lpDCB As DCB) As Long + + Private Type OVERLAPPED + Internal As Long + InternalHigh As Long + Offset As Long + OffsetHigh As Long + hEvent As Long + End Type + + Private Type COMMTIMEOUTS + ReadIntervalTimeout As Long + ReadTotalTimeoutMultiplier As Long + ReadTotalTimeoutConstant As Long + WriteTotalTimeoutMultiplier As Long + WriteTotalTimeoutConstant As Long + End Type + +#Else + ' 32-bit Kompilierung (Legacy Excel) + Private Declare Function CreateFile Lib "kernel32" _ + (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _ + ByVal dwShareMode As Long, lpSecurityAttributes As Any, _ + ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _ + ByVal hTemplateFile As Long) As Long + + Private Declare Function WriteFile Lib "kernel32" _ + (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, _ + lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long + + Private Declare Function ReadFile Lib "kernel32" _ + (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, _ + lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long + + Private Declare Function CloseHandle Lib "kernel32" _ + (ByVal hObject As Long) As Long + + Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) + + Private Declare Function SetCommTimeouts Lib "kernel32" _ + (ByVal hFile As Long, lpCommTimeouts As Any) As Long + + Private Declare Function GetCommTimeouts Lib "kernel32" _ + (ByVal hFile As Long, lpCommTimeouts As Any) As Long + + Private Declare Function SetupComm Lib "kernel32" _ + (ByVal hFile As Long, ByVal dwInQueue As Long, ByVal dwOutQueue As Long) As Long + + Private Type DCB + DCBlength As Long + BaudRate As Long + fBinary As Long + fParity As Long + fOutxCtsFlow As Long + fOutxDsrFlow As Long + fDtrControl As Long + fDsrSensitivity As Long + fTXContinueOnXoff As Long + fOutX As Long + fInX As Long + fErrorChar As Long + fNull As Long + fRtsControl As Long + fAbortOnError As Long + fDummy2 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 + End Type + + Private Declare Function BuildCommDCB Lib "kernel32" Alias _ + "BuildCommDCBA" (ByVal lpDef As String, lpDCB As DCB) As Long + + Private Declare Function SetCommState Lib "kernel32" _ + (ByVal hFile As Long, lpDCB As DCB) As Long + + Private Type OVERLAPPED + Internal As Long + InternalHigh As Long + Offset As Long + OffsetHigh As Long + hEvent As Long + End Type + + Private Type COMMTIMEOUTS + ReadIntervalTimeout As Long + ReadTotalTimeoutMultiplier As Long + ReadTotalTimeoutConstant As Long + WriteTotalTimeoutMultiplier As Long + WriteTotalTimeoutConstant As Long + End Type +#End If + +' API Konstanten +Private Const GENERIC_READ As Long = &H80000000 +Private Const GENERIC_WRITE As Long = &H40000000 +Private Const OPEN_EXISTING As Long = 3 +Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80 +Private Const COMM_CONFIG_SIZE As Long = 128 + +' RSAPI-kompatible öffentliche Schnittstelle +' Diese Sub/Function-Namen decken die original RSAPI-DLL API ab. + +Public hComPort As Long +Dim m_ComBuffer As String +Dim m_ReadTimeoutSet As Boolean + +' --- RSAPI-Kompatible Wrapper --- + +' OPENCOM "COM1:9600,N,8,1" oder einfach "COM1:57600,N,8,1" +Sub OPENCOM(ByVal ComParameter As String) + Dim comPort As String + Dim baudRate As Long + Dim parity As String + Dim dataBits As Integer + Dim stopBits As String + + ' Parsing: z.B. "COM1:9600,N,8,1" oder "COM3:57600,N,8,1" + If InStr(ComParameter, ":") > 0 Then + comPort = Left$(ComParameter, InStr(ComParameter, ":") - 1) + Dim settings As String + settings = Mid$(ComParameter, InStr(ComParameter, ":") + 1) + + ' Parsing der Baudraten-Settings + Dim parts() As String + parts = Split(settings, ",") + If UBound(parts) >= 3 Then + baudRate = CLng(Trim$(parts(0))) + parity = Trim$(parts(1)) + dataBits = CInt(Trim$(parts(2))) + stopBits = Trim$(parts(3)) + Else + ' Nur Baudrate angegeben: "COM1:57600" + baudRate = CLng(Trim$(settings)) + parity = "N" + dataBits = 8 + stopBits = "1" + End If + Else + ' Nur Port-Name ohne Baudrate — Default verwenden + comPort = ComParameter + baudRate = 9600 + parity = "N" + dataBits = 8 + stopBits = "1" + End If + + ' COM-Port Pfad konstruieren (\\.\COMx für moderne Windows) + Dim portName As String + portName = "\\.\\" & comPort + + ' DCB Struktur aufbauen + Dim dcb As DCB + Dim dcbDef As String + dcbDef = comPort & ":" & CStr(baudRate) & "," & parity & "," & CStr(dataBits) & "," & stopBits + + If BuildCommDCB(dcbDef, dcb) = 0 Then + Err.Raise vbObjectError + 1, , "BuildCommDCB failed for " & dcbDef + Exit Sub + End If + + ' Port öffnen + hComPort = CreateFile(portName, GENERIC_READ Or GENERIC_WRITE, _ + 0, ByVal 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0) + + If hComPort < 0 Then + Err.Raise vbObjectError + 2, , "CreateFile failed for " & portName & ". Port existiert nicht oder ist in Benutzung." + Exit Sub + End If + + ' COM-Port konfigurieren + If SetCommState(hComPort, dcb) = 0 Then + CloseHandle hComPort + hComPort = -1 + Err.Raise vbObjectError + 3, , "SetCommState failed" + Exit Sub + End If + + ' Buffers setzen + SetupComm hComPort, COMM_CONFIG_SIZE, COMM_CONFIG_SIZE + + ' Timeouts konfigurieren (non-blocking read) + Dim timeouts As COMMTIMEOUTS + Dim result As Long + result = GetCommTimeouts(hComPort, timeouts) + + ' Non-blocking Modus: sofort zurück wenn kein Data da + timeouts.ReadIntervalTimeout = &HFFFF& ' MAXULONG + timeouts.ReadTotalTimeoutMultiplier = 0 + timeouts.ReadTotalTimeoutConstant = 0 + timeouts.WriteTotalTimeoutMultiplier = 500 ' 0.5s write timeout + timeouts.WriteTotalTimeoutConstant = 1000 ' 1s absolute write timeout + + SetCommTimeouts hComPort, timeouts + + m_ReadTimeoutSet = True + m_ComBuffer = "" +End Sub + +' CLOSECOM — COM-Port schließen +Sub CLOSECOM() + If hComPort > 0 Then + CloseHandle hComPort + hComPort = -1 + m_ComBuffer = "" + End If +End Sub + +' TIMEINIT — Initialisiert Timeout-Mechanismus (hier implizit durch Timeouts) +Sub TIMEINIT() + ' In RSAPI.DLL aktiv; hier ist der Non-Blocking Modus bereits in OPENCOM gesetzt + m_ReadTimeoutSet = True +End Sub + +' TIMEOUT ms% — Setzt Timeout für READSTRING +Function TIMEOUT(ByVal ms As Long) As Long + Dim timeouts As COMMTIMEOUTS + Dim result As Long + + If hComPort > 0 Then + result = GetCommTimeouts(hComPort, timeouts) + + ' Total timeout setzen (ms/1000 als Sekunden) + timeouts.ReadIntervalTimeout = 0 + timeouts.ReadTotalTimeoutMultiplier = 0 + timeouts.ReadTotalTimeoutConstant = ms + timeouts.WriteTotalTimeoutMultiplier = 500 + timeouts.WriteTotalTimeoutConstant = 1000 + + SetCommTimeouts hComPort, timeouts + End If + + TIMEOUT = 1 ' Erfolg +End Function + +' TIMEREAD — Gibt verbleibende Zeit zurück (vereinfacht) +Function TIMEREAD() As Long + TIMEREAD = 0 ' In moderner Implementierung nicht benötigt +End Function + +' SENDBYTE B% — Sendet ein einzelnes Byte +Sub SENDBYTE(ByVal B As Integer) + Dim buf(0 To 3) As Byte + buf(0) = CByte(B And &HFF) + + Dim bytesWritten As Long + WriteFile hComPort, buf(0), 1, bytesWritten, ByVal 0& +End Sub + +' SENDSTRING S — Sendet einen String (ASCII) +Sub SENDSTRING(ByVal S As String) + Dim i As Integer + For i = 1 To Len(S) + SENDBYTE Asc(Mid$(S, i, 1)) + Next i +End Sub + +' READSTRING Display$ — Liest eine Zeile bis CR (0x0D) oder LF (0x0A) zurück +' Gibt die Anzahl gelesener Zeichen zurück +Function READSTRING(ByVal Display As String) As Integer + Dim result As Integer + result = RSAPI_READLINE(Display) + READSTRING = result + + ' Aufräumen: Buffer wenn komplett gelesen + If result <= 0 Then m_ComBuffer = "" +End Function + +' READBYTE — Liest ein einzelnes Byte zurück (als Integer -1 bei Timeout) +Function READBYTE() As Integer + Dim buf(0 To 255) As Byte + Dim bytesRead As Long + + Dim result As Long + result = ReadFile(hComPort, buf(0), 1, bytesRead, ByVal 0&) + + If result <> 0 And bytesRead > 0 Then + READBYTE = buf(0) ' Wert als Integer zurück + Else + READBYTE = -1 ' Error/Timeout + End If +End Function + +' STRLENGTH B% — Setzt Puffer-Größe (in der RSAPI für Display-Puffer; hier implizit) +Sub STRLENGTH(ByVal B As Integer) + ' In dieser Implementierung nicht nötig, da dynamisch +End Sub + +' DELAY ms% — Wartet ms Millisekunden (ersetzt Sleep) +Sub DELAY(ByVal ms As Integer) + Sleep ms +End Function + +' ============================================================ +' Interner Lese-Mechanismus — liest zeilenweise vom COM-Port +' ============================================================ +Private Function RSAPI_READLINE(ByRef OutputString As String) As Integer + Dim buf(0 To 255) As Byte + Dim bytesRead As Long + Dim readResult As Long + Dim ch As Byte + Dim lineBuffer As String + + lineBuffer = "" + + Do + readResult = ReadFile(hComPort, buf(0), 1, bytesRead, ByVal 0&) + + If readResult = 0 Or bytesRead = 0 Then + ' Timeout oder Fehler — gib was da ist zurück (oder leer) + RSAPI_READLINE = Len(lineBuffer) + If Len(lineBuffer) > 0 Then OutputString = lineBuffer Else OutputString = "" + Exit Function + End If + + ch = buf(0) + + ' Zeilenende: CR oder LF erkennen + If ch = &H0D Or ch = &HA Then + RSAPI_READLINE = Len(lineBuffer) + OutputString = lineBuffer + Exit Function + End If + + ' Buffer overflow Schutz + If Len(lineBuffer) > 254 Then + RSAPI_READLINE = Len(lineBuffer) + OutputString = lineBuffer + Exit Function + End If + + lineBuffer = lineBuffer & Chr$(ch) + + Loop +End Function + +' ============================================================ +' Originaler Code (mit minimalen Anpassungen) +' ============================================================ + +Public Label_Start, Label_Stop, Label_Trig, Label_FmaxChange, Label_FPeak +Public Title, Title_Distance, Title_F, Title_Speed, Title_Fmax, Title_Date, Title_Time +Public Rec_F, Rec_Fmax, Rec_Ftrig, Rec_Distance, Rel_Distance, Dir_Bit, Sensor_Factor, Rec_Speed, Rec_Fpeak, Baudrate +Public Temp_Speed, Years%, Months%, Days%, Hours%, Minutes%, Seconds%, Rec_Type, ADC_Offset, Stype_Def, Metric%, Time_Format%, Language% +Public Distance_Factor, Graph_F_$, Graph_Distance_$, Graph_V_$, Graph_Fmax_$, Graph_Date_$, Graph_Time_$, Speed_Factor +Public Blatt$, Password +Public PortNumber + +Dim Sensor_Type(32) +Dim Ftrigger_$(0 To 11) +Dim Fpeak_$(0 To 11) +Dim Fchange_$(0 To 11) +Dim sheetcounter As Integer + +' Private Function Fileishere(fname) As Boolean +' Returns TRUE if the file exists +Private Function Fileishere(fname As String) As Boolean + Dim x As String + x = Dir(fname) + If x <> "" Then Fileishere = True Else Fileishere = False +End Function + +Sub Set_Date() + Set_Com_Port + Open_Com + + DateStr$ = Mid$(Date$, 4, 2) + Mid$(Date$, 1, 2) + Mid$(Date$, 9, 2) + TimeStr$ = Mid$(Time$, 1, 2) + Mid$(Time$, 4, 2) + Mid$(Time$, 7, 2) + Time_Str$ = DateStr$ + TimeStr$ + + SENDSTRING ("D") + For i = 1 To 10 + c_Char = (Mid$(Time_Str$, i, 1)) + SENDSTRING (c_Char) + Next i + SENDSTRING (Chr(13)) + + CLOSECOM +End Sub + +Sub Clear_Memory() + Dim Msg, Style, Title, Response, MyString + Msg = "Clear MP 30?" + Style = vbYesNo + vbCritical + vbDefaultButton2 + Title = "Clear MP 30" + + Response = MsgBox(Msg, Style, Title) + If Response = vbYes Then + Set_Com_Port + Backlight_On + DELAY (500) + Backlight_Off + Open_Com + SENDSTRING ("$&" + Chr(13)) + CLOSECOM + End If +End Sub + +Sub Dump() + Set_Com_Port + conf$ = "COM " + Chr$(Asc(PortNumber)) + + Ftrigger_$(0) = "Fmax Stop" + Ftrigger_$(1) = "Fmax Stop" + Ftrigger_$(2) = "Fmax Stop" + Ftrigger_$(3) = "Fmax Stop" + Ftrigger_$(4) = "Fmax Stop" + Ftrigger_$(5) = "Fmax Stop" + Ftrigger_$(6) = "Fmax Stop" + Ftrigger_$(7) = "Fmax Stop" + Ftrigger_$(8) = "Fmax Stop" + Ftrigger_$(9) = "Fmax Stop" + Ftrigger_$(10) = "Fmax Stop" + Ftrigger_$(11) = "Fmax Stop" + + Fpeak_$(0) = "Peak Value" + Fpeak_$(1) = "Spitzenwert" + Fpeak_$(2) = "Valeur de crête" + Fpeak_$(3) = "Valor de cresta" + Fpeak_$(4) = "Valor massimo" + Fpeak_$(5) = "max. tazna F" + Fpeak_$(6) = "Peak Value" + Fpeak_$(7) = "Valore massima" + Fpeak_$(8) = "Spets värde" + Fpeak_$(9) = "Topp verdi" + Fpeak_$(10) = "Peak Value" + Fpeak_$(11) = "Peak Value" + + Fchange_$(0) = "Fmax Change" + Fchange_$(1) = "Fmax änderung" + Fchange_$(2) = "Changement Fmax" + Fchange_$(3) = "Cambio Fmax" + Fchange_$(4) = "Mudonça de Fmax" + Fchange_$(5) = "zmena max. F" + Fchange_$(6) = "Fmax Change" + Fchange_$(7) = "Cambiamento di Fmax" + Fchange_$(8) = "ända max last" + Fchange_$(9) = "Forendering max last" + Fchange_$(10) = "Fmax Change" + Fchange_$(11) = "Fmax Change" + + TempFile = TempDir$ + "\mp30_xxx.txt" + + Blatt$ = "MP30 Start" + + ThisWorkbook.Sheets(Blatt$).Activate + Password = "pw002" + ActiveSheet.Unprotect Password + + Worksheets("MP30 Start").Range("a9:H11000").ClearContents + + Cells(20, 4) = "Port: " + conf$ + Cells(21, 4) = "Software Release Ver. 2.4" + + NumOfVal = 0 + ReDim Sensor_Type(32) + Timeout_Interval = 10000 + + Open_Com + Number_Of_Records = 9600 + STRLENGTH 15 + Display$ = "000000000000000" + EOF_Str$ = "012" + EOF_Rec = 12 + Zeile = 3 + col_offset = 12 + Col_Dist_Abs = col_offset + Col_Dist_Rel = col_offset + 1 + Col_F = col_offset + 2 + Col_Speed = col_offset + 3 + Col_Fmax = col_offset + 4 + Col_Date = col_offset + 5 + Col_Time = col_offset + 6 + Col_Ftrig = col_offset + 7 + Col_Fpeak = col_offset + 8 + Col_Start = col_offset + 9 + Col_End = col_offset + 10 + Title = 10 + + Graph_Comment = 1 + Graph_F = 3 + Graph_distance = 2 + Graph_V = 4 + Graph_Dir = 8 + Graph_Fmax = 5 + Graph_Date = 6 + Graph_Time = 7 + Graph_Temp = 8 + + Cells(Title, Graph_F) = "F [daN]" + Cells(Title, Graph_distance) = "L [m]" + Cells(Title, Graph_V) = "V [m/min]" + Cells(Title, Graph_Fmax) = "Fmax [daN]" + Cells(Title, Graph_Date) = "Date" + Cells(Title, Graph_Time) = "Time" + + Sensor_Factor = 8394 / 1024 + Speed_Factor = 1 + Dist_metric_Factor = 0.04 + Distance_Factor = 1 + Store_Interval = 125 + ADC_Offset = 150 + Rec_Type = 0 + + Data_Rec = 0 + Start_Rec = 1 + Fmax_Rec = 5 + Ftrig_Rec = 6 + End_Rec = 9 + Fmax_alt_Rec = 11 + Data_at_Zero = 13 + + Total_Distance = 0 + Graph_Line = 3 + Rel_Distance = 0 + Abs_Distance = 0 + Years% = 0 + Months% = 0 + Days% = 0 + Hours% = 0 + Minutes% = 0 + Seconds% = 0 + + sheetcounter = 0 + DeleteNewSheets + + Open TempFile For Output As #1 + TIMEINIT + + Xmit$ = "?" + Chr(13) + SENDSTRING (Xmit$) + + TIMEOUT 500 + EOF_Flag = 0 + receive_ok = 1 + While (NumOfVal < Number_Of_Records) And (EOF_Flag = 0) + READSTRING (Display$) + If Left$(Display$, 6) = "Fehler" Or Display$ = "000000000000000" Then + EOF_Flag = 1 + receive_ok = 0 + Else + Print #1, Display$; + End If + NumOfVal = NumOfVal + 1 + TestStr$ = Left$(Display$, 3) + If TestStr$ = EOF_Str$ Then EOF_Flag = 1 + Wend + Close #1 + + If receive_ok = 1 Then + NumOfVal = 0 + Open TempFile For Input As #1 + + While (NumOfVal < Number_Of_Records) And (Rec_Type <> EOF_Rec) + Rec_Type = Read_Record + If Rec_Type = Start_Rec Then + Graph_Line = 11 + ActiveSheet.Protect Password + NewSheet_add + start_flag = 1 + + loc_rec = Read_Record ' ADC Offset and Sensor type Definition + If Metric% = 0 Then + Speed_Factor = 3.2808 + Distance_Factor = 3.28084 + Else + Speed_Factor = 1 + Distance_Factor = 1 + End If + loc_rec = Read_Record ' read F + loc_rec = Read_DateTime ' date & time + loc_rec = Read_Record + loc_rec = Read_Record ' read Fmax + loc_rec = Read_Record ' read distance + + Abs_Distance = Rec_Distance * Dist_metric_Factor + Rel_Distance = CInt(Rec_Distance / Store_Interval - 0.5) * Store_Interval + + Date_Str$ = Str$(Years%) + "-" + Str$(Months%) + "-" + Str$(Days%) + Time_Str$ = Str$(Hours%) + ":" + Str$(Minutes) + ":" + Str$(Seconds%) + + Cells(Graph_Line, Graph_Comment) = "Start" + Cells(Graph_Line, Graph_distance) = Abs_Distance * Distance_Factor + Cells(Graph_Line, Graph_distance).HorizontalAlignment = xlHAlignRight + Cells(Graph_Line, Graph_F) = Int(Rec_F) + Cells(Graph_Line, Graph_V) = Int(Rec_Speed) + Cells(Graph_Line, Graph_Fmax) = Int(Rec_Fmax) + Cells(Graph_Line, Graph_Date) = Date_Str$ + Cells(Graph_Line, Graph_Time) = Time_Str$ + + Graph_Line = Graph_Line + 1 + End If + + If Rec_Type = End_Rec Then + loc_rec = Read_Record ' read F + loc_rec = Read_DateTime ' date & time + loc_rec = Read_Record + loc_rec = Read_Record + loc_rec = Read_Record ' read stop distance + + Abs_Distance = Rec_Distance * Dist_metric_Factor + Rel_Distance = CInt(Rec_Distance / Store_Interval - 0.5) * Store_Interval + If Dir_Bit = 0 Then Rel_Distance = Rel_Distance + Store_Interval + + Date_Str$ = Str$(Years%) + "-" + Str$(Months%) + "-" + Str$(Days%) + Time_Str$ = Str$(Hours%) + ":" + Str$(Minutes) + ":" + Str$(Seconds%) + + Cells(Graph_Line, Graph_Comment) = "Stop" + Cells(Graph_Line, Graph_distance) = Abs_Distance * Distance_Factor + Cells(Graph_Line, Graph_distance).HorizontalAlignment = xlHAlignRight + Cells(Graph_Line, Graph_F) = Int(Rec_F) + Cells(Graph_Line, Graph_V) = Int(Rec_Speed) + Cells(Graph_Line, Graph_Date) = Date_Str$ + Cells(Graph_Line, Graph_Time) = Time_Str$ + + Graph_Line = Graph_Line + 1 + + loc_rec = Read_Record ' read Fpeak + loc_rec = Read_Record ' read distance + + Abs_Distance = Rec_Distance * Dist_metric_Factor + Cells(Graph_Line, Graph_Comment) = Fpeak_$(Language) + Cells(Graph_Line, Graph_distance) = Abs_Distance * Distance_Factor + Cells(Graph_Line, Graph_distance).HorizontalAlignment = xlHAlignRight + Cells(Graph_Line, Graph_F) = Int(Rec_Fpeak) + End If + + If Rec_Type = Ftrig_Rec Then + loc_rec = Read_Record ' read Distance + Abs_Distance = Rec_Distance * Dist_metric_Factor + Cells(Graph_Line, Graph_Comment) = Ftrigger_$(Language) + Cells(Graph_Line, Graph_distance) = Abs_Distance * Distance_Factor + Cells(Graph_Line, Graph_distance).HorizontalAlignment = xlHAlignRight + Cells(Graph_Line, Graph_F) = Int(Rec_Ftrig) + Graph_Line = Graph_Line + 1 + End If + + If Rec_Type = Fmax_alt_Rec Then + loc_rec = Read_Record ' read Distance + Abs_Distance = Rec_Distance * Dist_metric_Factor + Cells(Graph_Line, Graph_Fmax) = Int(Rec_Fmax) + Cells(Graph_Line, Graph_Comment) = Fchange_$(Language) + Cells(Graph_Line, Graph_distance) = Abs_Distance * Distance_Factor + Cells(Graph_Line, Graph_distance).HorizontalAlignment = xlHAlignRight + Graph_Line = Graph_Line + 1 + End If + + If (Rec_Type = Data_Rec) Or (Rec_Type = Data_at_Zero) Then + If start_flag = 1 Then + If Dir_Bit = 1 Then Rel_Distance = Rel_Distance + Store_Interval + start_flag = 0 + End If + If Dir_Bit = 0 Then + Rel_Distance = Rel_Distance + Store_Interval + Else + Rel_Distance = Rel_Distance - Store_Interval + End If + If Rec_Type = Data_at_Zero Then Rel_Distance = 0 + + Abs_Distance = Rel_Distance * Dist_metric_Factor + Cells(Graph_Line, Graph_F) = Int(Rec_F) + Cells(Graph_Line, Graph_V) = Int(Rec_Speed) + Temp_Dist = Abs_Distance * Distance_Factor + Cells(Graph_Line, Graph_distance) = Temp_Dist + Cells(Graph_Line, Graph_distance).HorizontalAlignment = xlHAlignRight + Graph_Line = Graph_Line + 1 + End If + + If Rec_Type = Offset_Rec Then + If Metric% = 0 Then + Cells(Title, Graph_F) = "F [lbs]" + Cells(Title, Graph_distance) = "L [ft]" + Cells(Title, Graph_V) = "V [ft/min]" + Cells(Title, Graph_Fmax) = "Fmax [lbs]" + Cells(Title, Graph_Date) = "Date" + Cells(Title, Graph_Time) = "Time" + End If + End If + + NumOfVal = NumOfVal + 1 + Wend + + Close #1 + End If + + ActiveSheet.Protect Password + Kill TempFile + CLOSECOM + Write_Unlocked_Cells + + Worksheets("MP30 Start").Unprotect Password + Worksheets("MP30 Start").Protect Password +End Sub + +Public Function Read_Record() As Integer + Input #1, Instring1$ + Rec_Type = Val(Instring1$) + + Input #1, Instring2$ + Temp_ADC = Int(Val(Instring2$)) And 1023 + + Input #1, Instring3$ + Temp_Speed = Val(Instring3$) + + If Rec_Type = 0 Then ' data record + If Int(Val(Instring2$)) >= 2048 Then + Dir_Bit = 1 + Else + Dir_Bit = 0 + End If + Rec_ADC = Temp_ADC - ADC_Offset + If Rec_ADC < 0 Then Rec_ADC = 0 + Rec_Speed = Temp_Speed * Speed_Factor + Rec_F = Rec_ADC * Sensor_Factor + If Rec_F > 0 Then Rec_F = Rec_F - 0.5 + End If + + If Rec_Type = 1 Then Language = Temp_ADC + If Rec_Type = 2 Then ' date record + Years% = (Int(Temp_ADC / 16) * 10) + (Temp_ADC Mod 16) + 2000 + Months% = (Int(Temp_Speed / 16) * 10) + (Temp_Speed Mod 16) + End If + + If Rec_Type = 3 Then ' date record - day/time + Days% = (Int(Temp_ADC / 16) * 10) + (Temp_ADC Mod 16) + Hours% = (Int(Temp_Speed / 16) * 10) + (Temp_Speed Mod 16) + If Time_Format Then + If Hours% = 0 Then Hours% = 12 + If Hours% > 12 Then Hours% = Hours - 12 + End If + End If + + If Rec_Type = 4 Then ' seconds + Minutes% = (Int(Temp_ADC / 16) * 10) + (Temp_ADC Mod 16) + Seconds% = (Int(Temp_Speed / 16) * 10) + (Temp_Speed Mod 16) + End If + + If Rec_Type = 5 Then ' Fmax record + Rec_ADC = (Temp_ADC - ADC_Offset) * Sensor_Factor + If Rec_ADC < 0 Then Rec_ADC = 0 + Rec_Fmax = Rec_ADC + If Rec_Fmax > 0 Then Rec_Fmax = Rec_Fmax - 0.5 + End If + + If Rec_Type = 6 Then ' Ftrigger record + Rec_ADC = Temp_ADC - ADC_Offset + If Rec_ADC < 0 Then Rec_ADC = 0 + Rec_Speed = Temp_Speed + Rec_Ftrig = Rec_ADC * Sensor_Factor + If Rec_Ftrig > 0 Then Rec_Ftrig = Rec_Ftrig - 0.5 + End If + + If Rec_Type = 7 Then ' distance record + Rec_Distance = Temp_ADC * 256 + Temp_Speed + End If + + If Rec_Type = 8 Then ' Fpeak record + Rec_ADC = Temp_ADC - ADC_Offset + If Rec_ADC < 0 Then Rec_ADC = 0 + Rec_Speed = Temp_Speed + Rec_Fpeak = Rec_ADC * Sensor_Factor + If Rec_Fpeak > 0 Then Rec_Fpeak = Rec_Fpeak - 0.5 + End If + + If Rec_Type = 10 Then ' F record + Rec_ADC = Temp_ADC - ADC_Offset + If Rec_ADC < 0 Then Rec_ADC = 0 + Rec_Speed = Temp_Speed * Speed_Factor + Rec_F = Rec_ADC * Sensor_Factor + If Rec_F > 0 Then Rec_F = Rec_F - 0.5 + End If + + If Rec_Type = 11 Then ' Fmax altered record + Feff = (Temp_ADC - ADC_Offset) * Sensor_Factor + Rec_Fmax = Feff + If Rec_Fmax > 0 Then Rec_Fmax = Rec_Fmax - 0.5 + End If + + If Rec_Type = 12 Then ' EOF record + Rec_ADC = Temp_ADC + End If + + If Rec_Type = 13 Then ' zero crossing record + Rec_ADC = Temp_ADC - ADC_Offset + If Rec_ADC < 0 Then Rec_ADC = 0 + Rec_Speed = Temp_Speed * Speed_Factor + Rec_F = Rec_ADC * Sensor_Factor + If Rec_F > 0 Then Rec_F = Rec_F - 0.5 + Rel_Distance = 0 + End If + + If Rec_Type = 14 Then ' ADC Offset and Sensor Type + Sensor_Type(0) = 1343 '/*0, 40 bar, 50mm, metric, 500 daN*/ + Sensor_Type(1) = 2015 '/*1, 60 bar, 50mm, metric, 750 daN */ + Sensor_Type(2) = 3358 '/*2, 100 bar, 50mm, metric, 1500 daN */ + Sensor_Type(3) = 5372 '/*3, 160 bar, 50mm, metric, 2300 daN */ + Sensor_Type(4) = 8394 '/*4, 250 bar, 50mm, metric, 3300 daN */ + Sensor_Type(5) = 8394 '/*5, 250 bar, 50mm, metric, 4300 daN */ + Sensor_Type(6) = 13430 '/*6, 400 bar, 50mm, metric, 7500 daN */ + Sensor_Type(7) = 21489 '/*7, 160 bar, 100mm, metric, 10 kdaN */ + Sensor_Type(8) = 33576 '/*8, 250 bar, 100mm, metric, 15 kdaN*/ + Sensor_Type(9) = 53721 '/*9, 400 bar, 100mm, metric, 20..30 kdaN*/ + Sensor_Type(10) = 53721 '/*10, 400 bar, 100mm, metric, 20..30 daN*/ + Sensor_Type(11) = 53721 '/*11, 400 bar, 100mm, metric, 20..30 daN */ + Sensor_Type(12) = 5372 '/*3, 160 bar, 50mm, metric, 2300 daN */ + Sensor_Type(13) = 0 '/*13, reserve metric */ + Sensor_Type(14) = 0 '/*14, reserve metric */ + Sensor_Type(15) = 0 '/*15, reserve metric */ + '/* resolution 1 lbs */ + Sensor_Type(16) = 3019 '/*0, 40 bar, 50mm, lbs, 500 daN*/ + Sensor_Type(17) = 4529 '/*1, 60 bar, 50mm, lbs, 750 daN */ + Sensor_Type(18) = 7548 '/*2, 100 bar, 50mm, lbs, 1500 daN */ + Sensor_Type(19) = 12077 '/*3, 160 bar, 50mm, lbs, 2300 daN */ + Sensor_Type(20) = 18870 '/*4, 250 bar, 50mm, lbs, 3300 & 4300 daN */ + Sensor_Type(21) = 18870 '/*5, 400 bar, 50mm, lbs, 7500 daN */ + Sensor_Type(22) = 30193 '/*6, 160 bar, 100mm, lbs, 10 kdaN */ + '/* mult factor is 256 here */ + Sensor_Type(23) = 48308 '/*7, 250 bar, 100mm, lbs, 15 kdaN */ + Sensor_Type(24) = 18870 '/*8, 400 bar, 100mm, lbs, 20..30 daN */ + Sensor_Type(25) = 30193 '/*9, 400 bar, 100mm, lbs, 20 daN */ + Sensor_Type(26) = 30193 '/*10, 400 bar, 100mm, lbs, 25 daN */ + Sensor_Type(27) = 30193 '/*11, 400 bar, 100mm, lbs, 30 daN */ + Sensor_Type(28) = 12077 '/*3, 160 bar, 50mm, lbs, 2300 daN */ + Sensor_Type(29) = 0 '/*13, reserve */ + Sensor_Type(30) = 0 '/*14, reserve */ + Sensor_Type(31) = 0 '/*15, reserve */ + + ADC_Offset = Temp_ADC + Stype_Def = Temp_Speed And 31 + If (Temp_Speed And 32) <> 0 Then + Metric% = 0 + Speed_Factor = 3.2808 + Else + Metric% = 1 + Speedfactor = 1 + End If + + If (Temp_Speed And 64) <> 0 Then Time_Format% = 1 Else Time_Format% = 0 + testvar = Sensor_Type(Stype_Def) + + If (Stype_Def < 24) Or (Stype_Def = 28) Then + Sensor_Factor = Sensor_Type(Stype_Def) / 1024 + Else + Sensor_Factor = Sensor_Type(Stype_Def) / 256 + End If + End If + + Read_Record = Rec_Type +End Function + +' Neue Hilfsfunktion zum Lesen von Datum/Zeit Records (Typ 3 und 4 zusammen) +Private Sub Read_DateTime() + ' Liest zwei Record-Typen hintereinander aus dem File + Dim tempType As Integer + Input #1, Instring1$ + Rec_Type = Val(Instring1$) + + If Rec_Type = 3 Then ' Day/Hours + Days% = (Int(Temp_ADC / 16) * 10) + (Temp_ADC Mod 16) + Hours% = (Int(Temp_Speed / 16) * 10) + (Temp_Speed Mod 16) + ElseIf Rec_Type = 4 Then ' Minutes/Seconds + Minutes% = (Int(Temp_ADC / 16) * 10) + (Temp_ADC Mod 16) + Seconds% = (Int(Temp_Speed / 16) * 10) + (Temp_Speed Mod 16) + End If + + ' Speichere Typ für späteren Vergleich in Dump() + Read_Record = Rec_Type +End Sub + +Public Sub ADjust_Offset() + Open_Com + SENDSTRING ("O%" + Chr(13)) + CLOSECOM +End Sub + +Public Sub Backlight_On() + Open_Com + SENDSTRING ("B1" + Chr(13)) + CLOSECOM +End Sub + +Public Sub Backlight_Off() + Open_Com + SENDSTRING ("B0" + Chr(13)) + CLOSECOM +End Sub + +Public Sub Welcome_Screen() + Dim Welcome(4) As String + + Open_Com + + Welcome(0) = Left(Cells(2, 7), 20) & " " + Welcome(1) = Left(Cells(3, 7), 20) & " " + Welcome(2) = Left(Cells(4, 7), 20) & " " + Welcome(3) = Left(Cells(5, 7), 20) & " " + Delay_Var = 100 + + SENDSTRING ("W" & Chr(238) & Chr(13)) + DELAY (Delay_Var) + + For i = 0 To 3 + SENDSTRING ("W" & Left$(Welcome(i), 5) & Chr(13)) + DELAY (Delay_Var) + + SENDSTRING ("W" & Mid$(Welcome(i), 6, 5) & Chr(13)) + DELAY (Delay_Var) + + SENDSTRING ("W" & Mid$(Welcome(i), 11, 5) & Chr(13)) + DELAY (Delay_Var) + + SENDSTRING ("W" & Mid$(Welcome(i), 16, 5) & Chr(13)) + DELAY (Delay_Var) + Next i + + CLOSECOM +End Sub + +Public Sub Open_Com() + If Baudrate = 0 Then + If PortNumber = 1 Then OPENCOM "COM1:9600,N,8,1" + If PortNumber = 2 Then OPENCOM "COM2:9600,N,8,1" + If PortNumber = 3 Then OPENCOM "COM3:9600,N,8,1" + If PortNumber = 4 Then OPENCOM "COM4:9600,N,8,1" + If PortNumber = 5 Then OPENCOM "COM5:9600,N,8,1" + If PortNumber = 6 Then OPENCOM "COM6:9600,N,8,1" + If PortNumber = 7 Then OPENCOM "COM7:9600,N,8,1" + If PortNumber = 8 Then OPENCOM "COM8:9600,N,8,1" + Else + OPENCOM "COM1:57600,N,8,1" + Baudrate = 1 + End If +End Sub + +Public Sub Set_Com_Port() + Dim TempDir$ As String + Dim ConfigFile As String + Dim conf$ As String + TempDir$ = Environ("temp") + ConfigFile = TempDir$ + "\MP30_Config.txt" + + If Fileishere(ConfigFile) Then + Open ConfigFile For Input As #2 + Input #2, conf$ + PortNumber = Val(Right$(conf$, 1)) + Close #2 + + If PortNumber < 1 Or PortNumber > 8 Then + PortNumber = 1 + End If + Else + PortNumber = 1 + End If +End Sub + +Public Sub Baud_9600() + OPENCOM "COM1:57600,N,8,1" + SENDSTRING ("U#" + Chr(13)) + CLOSECOM + DELAY (100) + OPENCOM "COM1:9600,N,8,1" + SENDSTRING (Chr(13) + "U%" + Chr(13)) + CLOSECOM + DELAY (100) + Baudrate = 0 +End Sub + +Public Sub Baud_57600() + OPENCOM "COM1:9600,N,8,1" + SENDSTRING ("U%" + Chr(13)) + CLOSECOM + DELAY (100) + OPENCOM "COM1:57600,N,8,1" + SENDSTRING (Chr(13) + "U#" + Chr(13)) + CLOSECOM + DELAY (100) + Baudrate = 1 +End Sub + +Sub NewSheet_add() + Dim ws As Worksheet + + sheetcounter = sheetcounter + 1 + Set NewSheet = Worksheets.Add + NewSheet.Name = "MP 30_" & CStr(sheetcounter) + NewSheet.Move after:=Sheets(sheetcounter) + Worksheets("MP30 Start").Unprotect Password + Worksheets("MP30 Start").Range("A1:G11").Copy _ + Destination:=Worksheets(NewSheet.Name).Range("A1:G11") + Worksheets(NewSheet.Name).Columns(1).Font.Bold = True + + SetColumnWidthMM 1, 30 + SetRowHeightMM 1, 25 + SetColumnWidthMM 2, 20 + SetColumnWidthMM 3, 20 + SetColumnWidthMM 4, 20 + SetColumnWidthMM 5, 25 + SetColumnWidthMM 6, 20 + SetColumnWidthMM 7, 18 + + FormatColumn + Worksheets(NewSheet.Name).PageSetup.CenterHeader = "&16&B&A" + With Worksheets(NewSheet.Name).PageSetup + .PrintTitleRows = ("$A1:$G10") + .LeftMargin = Application.InchesToPoints(1) + End With + + With Worksheets(NewSheet.Name) + .Rows(11).Select + .Application.ActiveWindow.FreezePanes = True + End With +End Sub + +Sub Write_Unlocked_Cells() + Dim Sh As Worksheet + SheetName = "MP 30_" + + For Each Sh In ThisWorkbook.Worksheets + If Left$(Sh.Name, 12) = SheetName Or Sh.Name = "MP30 Start" Then + Sh.Unprotect Password + Sh.Select + Sh.Protect userinterfaceonly:=True + Sh.EnableSelection = xlUnlockedCells + Sh.Protect Password + End If + Next +End Sub + +Sub DeleteNewSheets() + Dim ws As Worksheet + Dim SheetName As String + SheetName = "MP 30_" + + For Each ws In Worksheets + If Left$(ws.Name, 6) = SheetName Then + ThisWorkbook.Sheets(ws.Name).Activate + Application.DisplayAlerts = False + ActiveSheet.Delete + Application.DisplayAlerts = True + End If + Next +End Sub + +Sub SetColumnWidthMM(ColNo As Long, mmWidth As Integer) + Dim w As Single + If ColNo < 1 Or ColNo > 255 Then Exit Sub + Application.ScreenUpdating = False + w = Application.CentimetersToPoints(mmWidth / 10) + + While Columns(ColNo + 1).Left - Columns(ColNo).Left - 0.1 > w + Columns(ColNo).ColumnWidth = Columns(ColNo).ColumnWidth - 0.1 + Wend + + While Columns(ColNo + 1).Left - Columns(ColNo).Left + 0.1 < w + Columns(ColNo).ColumnWidth = Columns(ColNo).ColumnWidth + 0.1 + Wend +End Sub + +Sub SetRowHeightMM(RowNo As Long, mmHeight As Integer) + If RowNo < 1 Or RowNo > 65536 Then Exit Sub + Rows(RowNo).RowHeight = Application.CentimetersToPoints(mmHeight / 10) +End Sub + +Sub set_port1() + OpenCom_Str$ = "COM1:9600,N,8,1" + PortNumber = 1 + write_conf +End Sub + +Sub set_port2() + OpenCom_Str$ = "COM2:9600,N,8,1" + PortNumber = 2 + write_conf +End Sub + +Sub set_port3() + OpenCom_Str$ = "COM3:9600,N,8,1" + PortNumber = 3 + write_conf +End Sub + +Sub set_port4() + OpenCom_Str$ = "COM4:9600,N,8,1" + PortNumber = 4 + write_conf +End Sub + +Sub set_port5() + OpenCom_Str$ = "COM5:9600,N,8,1" + PortNumber = 5 + write_conf +End Sub + +Sub set_port6() + OpenCom_Str$ = "COM6:9600,N,8,1" + PortNumber = 6 + write_conf +End Sub + +Sub set_port7() + OpenCom_Str$ = "COM7:9600,N,8,1" + PortNumber = 7 + write_conf +End Sub + +Sub set_port8() + OpenCom_Str$ = "COM8:9600,N,8,1" + PortNumber = 8 + write_conf +End Sub + +Sub write_conf() + TempDir$ = Environ("temp") + + ConfigFile = TempDir$ + "\MP30_Config.txt" + Kill ConfigFile + Open ConfigFile For Output As #2 + conf$ = "COM " & Chr$(Asc(PortNumber)) + Print #2, conf$ + Close #2 + + Password = "pw002" + Worksheets("MP30 Start").Unprotect Password + Worksheets("MP30 Start").Cells(20, 4) = "Port: " & conf$ + Worksheets("MP30 Start").Protect Password +End Sub + +Sub FormatColumn() + Columns("B:B").Select + Selection.NumberFormat = "0.0" +End Sub