BK 2650 VBA Script26.dec 2010
Dim bRunning As Boolean Dim bSpectrum As Boolean Dim bParameters As Boolean Dim nSpecLine As Integer Dim strReadBuf As String Dim nTotalread As Integer Dim dbFreq As Double Dim dbSpan As Double Dim dbScale As Double Dim dbReference As Double Dim nColumn As Integer Const Hz As Double = 1 Const kHz As Double = 1000 * Hz Const MHz As Double = 1000 * kHz Const GHz As Double = 1000 * MHz ' Code Sub BtnSend() If bRunning Then nColumn = Val(Cells(2, 4)) Send (Cells(2, 1)) End If End Sub Function Level(i As Integer) As Double Level = dbReference - (192 - i) / 24 * dbScale End Function Function Double2Str(d As Double, center As Double) As String If center > 10 * GHz Then Double2Str = Format(d / GHz, "0.000") & " GHz": Exit Function If center > 100 * MHz Then Double2Str = Format(d / MHz, "0") & " MHz": Exit Function If center > 10 * MHz Then Double2Str = Format(d / MHz, "0.0") & " MHz": Exit Function If center > 10 * kHz Then Double2Str = Format(d / kHz, "0.000") & " kHz": Exit Function Double2Str = Format(d, "0") & " Hz" End Function Function Str2Double(str As String) As Double str = Trim$(str) If str = "FULL" Then Str2Double = 3.3 * GHz: Exit Function If str = "ZERO" Then Str2Double = 0: Exit Function Select Case Right$(str, 1) Case "G": Str2Double = Val(Mid$(str, 1, Len(str) - 1)) * GHz: Exit Function Case "M": Str2Double = Val(Mid$(str, 1, Len(str) - 1)) * MHz: Exit Function Case "k": Str2Double = Val(Mid$(str, 1, Len(str) - 1)) * kHz: Exit Function End Select MsgBox "Cant decode value " & str End Function Function Freq(nSample As Integer, nTotal As Integer) If dbSpan = 0 Then Freq = dbFreq: Exit Function Freq = (nSample - 500) / 500 * (dbSpan / 2) + dbFreq End Function Sub RunThread() Dim nCounter As Integer Dim buf As String Dim rd As String Dim Line As String Dim i As Integer Dim hex As String Dim bProcessed As Boolean Dim strProgress As String strProgress = "/-\|/-\|" bCritical = False OpenPort While bRunning Cells(1, 1) = Mid$(strProgress, 1 + (nCounter Mod Len(strProgress)), 1) nCounter = (nCounter + 1) Mod 1000 Do For i = 0 To 1000 DoEvents Next i rd = Read() bProcessed = False If Len(rd) > 0 Then If Right$(rd, 2) = Chr$(&HD) + Chr$(&HA) Then Line = Left$(rd, Len(rd) - 2) If bSpectrum Then If Right$(Line, 1) = "," Then bProcessed = True For i = 1 To Len(Line) - 2 Step 3 hex = Mid$(Line, i, 2) Cells(nSpecLine + 1, nColumn + 0) = Level(Val("&h" + hex)) Cells(nSpecLine + 1, nColumn + 1) = Freq(nSpecLine, 1001) / MHz 'Double2Str(Freq(nSpecLine, 1001), dbFreq) nSpecLine = nSpecLine + 1 Next Cells(1, 2) = "Samples=" & nSpecLine Cells(1, 4) = "Read Buffer=" & nTotalread Else bSpectrum = False End If End If If Line = "TRACE" Then bSpectrum = True bParameters = False nSpecLine = 0 End If If bParameters Then If Left$(Line, 3) = "CF " Then Cells(1, 13) = Mid$(Line, 3): dbFreq = Str2Double(Mid$(Line, 3)): bProcessed = True If Left$(Line, 3) = "SP " Then Cells(2, 13) = Mid$(Line, 3): dbSpan = Str2Double(Mid$(Line, 3)): bProcessed = True If Left$(Line, 3) = "RF " Then Cells(3, 13) = Mid$(Line, 3): dbReference = Val(Mid$(Line, 3)): bProcessed = True If Left$(Line, 3) = "ST " Then Cells(4, 13) = Mid$(Line, 3): bProcessed = True If Left$(Line, 3) = "RB " Then Cells(5, 13) = Mid$(Line, 3): bProcessed = True If Left$(Line, 3) = "VB " Then Cells(6, 13) = Mid$(Line, 3): bProcessed = True If Left$(Line, 3) = "SC " Then Cells(7, 13) = Mid$(Line, 3): dbScale = Val(Mid$(Line, 3)): bProcessed = True 'MsgBox "Unknown parameter " + Line End If If Line = "PARAM" Then bParameters = True End If If Not bProcessed Then Cells(3, 1) = Right$(Cells(3, 1) + rd, 128) End If End If End If Loop While Len(rd) > 0 Wend ClosePort End Sub ' Handlers Sub BtnStart() strReadBuf = "" nTotalread = 0 If Not bRunning Then bRunning = True RunThread End If End Sub Sub BtnStop() bRunning = False End Sub Sub Test(ret As Long, Msg As String) If ret <> 0 Then MsgBox "Err " & Msg End If End Sub Sub OpenPort() Dim intPortID As Integer ' Ex. 1, 2, 3, 4 for COM1 - COM4 Dim lngStatus As Long intPortID = 1 ' Open COM port Test CommOpen(intPortID, "COM" & CStr(intPortID), _ "baud=38400 parity=N data=8 stop=1 xon=on dtr=on rts=on"), "Open" End Sub Sub ClosePort() Dim intPortID As Integer ' Ex. 1, 2, 3, 4 for COM1 - COM4 intPortID = 1 Call CommClose(intPortID) End Sub Sub Send(str As String) Dim intPortID As Integer ' Ex. 1, 2, 3, 4 for COM1 - COM4 Dim lngStatus As Long Dim strData As String intPortID = 1 strData = str + Chr$(13) + Chr$(10) 'Writa data Test CommWrite(intPortID, strData) - Len(strData), "CommWrite" End Sub Function Read() As String Dim intPortID As Integer ' Ex. 1, 2, 3, 4 for COM1 - COM4 Dim lngStatus As Long Dim strData As String Dim strLine As String Dim strREMain As String Dim nRet As Integer If Not bRunning Then Exit Function intPortID = 1 lngStatus = CommRead(intPortID, strData, 4096) nTotalread = nTotalread + lngStatus strReadBuf = strReadBuf + strData If lngStatus <> -1 And lngStatus <> Len(strData) Then bRunning = False ClosePort MsgBox "buffer mismatch, size = " & lngStatus End If nRet = InStr(strReadBuf, Chr$(13) + Chr$(10)) If nRet > 0 Then strLine = Left(strReadBuf, nRet + 1) strReadBuf = Mid$(strReadBuf, nRet + 2) Else strLine = "" End If Read = strLine End Function