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