Option Explicit
'// VB Web MSCOMM example
'// (c) 1999-2000
'// www.vbweb.co.uk
' Modified for use with RT-1446 Transceiver by Ken Fowler
' 4 Nov. 2010
' v0.3 Completed 12-16-10
' v0.30 Started 1-6-11
' 8-16-11   Fixed bug which caused hang if InBuffer started with vblf.
' 8-18-11   SendCommand_Click () disabled SendSync and didn't re-enable it.
'
    Dim getStatus As Boolean
    Const Program As String = "RT1446Probe"
    Const Version As String = "V0.40"
    Const BuildDate As String = "8-18-11:2116"
    Dim NewData As Boolean, rStatus As Boolean
    Dim rBuffer As String
    Dim JCounter As Integer
    Dim UTime0 As Double
    Dim UEnable As Boolean, SaveUEnable As Boolean
    Dim EvReceiveWaitTime As Double
    
Private Sub Form_Load()
    Dim i As Integer
    Dim sSettings As String
    Dim BeginToken As Long, EndToken As Long
    Dim NextToken As String

    cboCommPort.Text = MSComm1.CommPort
    sSettings = MSComm1.Settings
    cboBaudRate.Text = "9600"
    cboParity.Text = "O"
    cboDataBits.Text = "7"
    cboStopBits.Text = "1"
    cboCommand.ListIndex = 0
    
    frmRT1446Probe.Caption = Program & " " & Version & " " & BuildDate
    
    '// get comm ports
    Show
    DoEvents
    ListComPorts

OpenComPort:
    Do While cmdCOMStatus.Caption = "Start Probe"
        DoEvents
    Loop
    
    EvReceiveWaitTime = 0.03
    JCounter = 0
    UTime0 = Timer
    cmdGetStatus.Enabled = True
    
    Do While cmdCOMStatus.Caption = "Stop Probe"
        If NewData Then
            MSComm1.RThreshold = 0
            NewData = False
            BeginToken = 1
            EndToken = 1
            rStatus = False
            ' Find Tokens with Linefeeds and pass to Display Token.
            Do While BeginToken < Len(rBuffer)
                EndToken = InStr(BeginToken, rBuffer, vbLf, vbBinaryCompare)
                If EndToken = 0 Then GoTo nolinefeed
                If EndToken >= BeginToken Then
                    Mid$(rBuffer, EndToken, 1) = "<"
                    NextToken = Mid$(rBuffer, BeginToken, EndToken - BeginToken)
                    If EndToken > BeginToken Then Call DisplayToken(NextToken)
                    If Mid$(NextToken, 1, 1) = "." Then rStatus = True
                    BeginToken = EndToken + 1
                End If
            Loop ' Do While
nolinefeed:
            If rStatus Then
                txtFromRT1446.Text = rBuffer
                EvReceiveWaitTime = 0.03
                UEnable = SaveUEnable
            End If
            cmdGetStatus.Enabled = True
            rBuffer = ""
            'LED(1).FillColor = vbWhite
            MSComm1.RThreshold = 1
        End If 'NewData
        If Timer < UTime0 Then UTime0 = UTime0 - 86400
        If JCounter >= 15 Then
            JCounter = 0
            Call SendSync
        ElseIf Timer - UTime0 > 1.55 Then
            Call SendSync
        End If

        If Timer - UTime0 > 0.5 Then LED(0).FillColor = vbWhite
        DoEvents
    Loop
    GoTo OpenComPort
End Sub

Private Sub SendSync()
    If UEnable Then
        cmdSendCmd.Enabled = False
        MSComm1.Output = "U"
        UTime0 = Timer
        LED(0).FillColor = vbGreen
        cmdSendCmd.Enabled = True
    End If
End Sub

Private Sub cboComm_Change()
    Dim sSettings As String
On Error Resume Next
    If cmdCOMStatus.Caption = "Open COM Port" Then
        ' Set the baud and bits
        sSettings = cboBaudRate.Text
        sSettings = sSettings & "," & cboParity.Text
        sSettings = sSettings & "," & cboDataBits.Text
        sSettings = sSettings & "," & cboStopBits.Text
        MSComm1.CommPort = cboCommPort.Text
        MSComm1.Settings = sSettings
        If Err Then
            SetStatus "Err " & Err & ". " & Error, True
        Else
            SetStatus "Changed to Com Port " & cboCommPort.Text, True
        End If
    End If
End Sub

Private Sub cboComm_Click()
    Call cboComm_Change
End Sub

Private Sub cboBaudRate_Click()
    Call cboComm_Change
End Sub

Private Sub cmdClearError_Click()
    txtErrMsg.Text = ""
End Sub

Private Sub cmdClearResponse_Click()
    Dim i As Integer
    Dim txt As TextBox
    
    With StatusToken
        For Each txt In StatusToken
            txt.Text = ""
        Next
    End With
End Sub

Private Sub cmdClearFromRT_Click()
    txtFromRT1446.Text = ""
End Sub

Private Sub ListComPorts()
    Dim i As Integer
    
    cboCommPort.Clear
    SetStatus "Getting Available Com Ports...", True
    For i = 1 To 16
        If COMAvailable(i) Then
            cboCommPort.AddItem i
            SetStatus "Com " & i & " found", False
        End If
    Next
    cboCommPort.ListIndex = 0
End Sub

Private Sub cmdGetComPorts_Click()
    ListComPorts
End Sub

Private Sub cmdSendCmd_Click()
On Error GoTo ErrHandler
    Dim sLastString As String
    Dim sOutput As String
    Dim sBuffer As String
    Dim i As Long
    
    On Error GoTo ErrHandler
    EvReceiveWaitTime = 0.065
    SaveUEnable = UEnable
    UEnable = False
    With MSComm1
        '// open port
        If cmdCOMStatus.Caption = "Open COM Port" Then Call cmdCOMStatus_Click
        '// send command
        sOutput = cboCommand.Text
        ' If Mid$(sOutput, 1, 2) = "?!" Then getStatus = True
        For i = 1 To Len(sOutput)
            If Mid$(sOutput, i, 1) = "!" Then Mid$(sOutput, i, 1) = Chr$(10)
            Next i
        If Mid$(sOutput, Len(sOutput), 1) <> Chr$(10) Then sOutput = sOutput & Chr$(10)
        SetStatus "Sending " & sOutput & " command...", True
        .Output = sOutput
        txtCommandTime.Text = Str$(Timer)
    End With
    UEnable = SaveUEnable
    Exit Sub
ErrHandler:
    SetStatus "Err " & Err & ". " & Error, True
End Sub

Private Sub cmdCOMStatus_Click()
On Error GoTo ErrHandler
    If cmdCOMStatus.Caption = "Stop Probe" Then
        If cmdSyncOnOff.Caption = "Stop Sync" Then
            Call cmdSyncOnOff_Click
        End If
        SetStatus "Closing COM Port " & MSComm1.CommPort, True
        Do While MSComm1.OutBufferCount <> 0
            DoEvents
        Loop
        MSComm1.PortOpen = False
        cmdCOMStatus.Caption = "Start Probe"
        cboBaudRate.Enabled = True
        cboCommPort.Enabled = True
    Else
        SetStatus "Opening COM Port " & MSComm1.CommPort, True
        cmdCOMStatus.Caption = "Stop Probe"
        cboBaudRate.Enabled = False
        cboCommPort.Enabled = False
        With MSComm1
            .CommPort = cboCommPort.Text
            .Settings = cboBaudRate.Text & "," & cboParity.Text & "," & cboDataBits.Text & "," & cboStopBits.Text
            .Handshaking = 0
            .InputMode = comInputModeText
            .RThreshold = 1
            .InBufferSize = 2048
            .InputLen = 0
            .InBufferCount = 0
            .PortOpen = True
        End With
      End If
    Exit Sub
ErrHandler:
    SetStatus "Err " & Err & ". " & Error, True
End Sub
Private Sub cmdSyncOnOff_Click()
    If cmdSyncOnOff.Caption = "Start Sync" Then
        cmdSyncOnOff.Caption = "Stop Sync"
        'If cmdCOMStatus.Caption = "Open COM Port" Then Call cmdCOMStatus_Click
        'UTimer.Interval = 1500
        'UTimer.Enabled = True
        'MSComm1.Output = "U"
        'LED(0).FillColor = vbGreen
        UEnable = True
    Else
        cmdSyncOnOff.Caption = "Start Sync"
        'UTimer.Enabled = False
        UEnable = False
        LED(0).FillColor = vbWhite
    End If
End Sub

Private Sub UTimer_Timer()
    If LED(0).FillColor = vbGreen Then
        LED(0).FillColor = vbWhite
    Else
        LED(0).FillColor = vbGreen
        MSComm1.Output = "U"
    End If
End Sub

Private Sub cmdGetStatus_Click()
    On Error Resume Next
    'If cmdCOMStatus.Caption = "Start Probe" Then Call cmdCOMStatus_Click
    EvReceiveWaitTime = 0.065
    SaveUEnable = UEnable
    UEnable = False
    MSComm1.Output = "?" & vbLf
    cmdGetStatus.Enabled = False
End Sub

Private Sub MSComm1_OnComm()
    Dim sMessage As String
    Dim t0 As Double
    
    On Error GoTo ErrHandler
    
    Select Case MSComm1.CommEvent
        ' Event messages.
        Case comEvReceive
        'LED(1).FillColor = vbRed
        ' MSComm Input Buffer has some chars. Get Chars from buffer and wait
        ' for more. Continue until MSComm Input Buffer is empty for 30 milliseconds.
            t0 = Timer
            Do While Timer - t0 < EvReceiveWaitTime
                ' If MSComm1.InBufferCount > 0 Then MoreChars = True
                If MSComm1.InBufferCount > 0 Then
                    rBuffer = rBuffer & MSComm1.Input
                    MSComm1.InBufferCount = 0
                    t0 = Timer
                End If
                If Timer < t0 Then t0 = t0 - 86400
            Loop ' Do While
            NewData = True
            If InStr(1, rBuffer, cmbInitial.Text, vbTextCompare) > 0 Then
                txtResponseTime.Text = Timer
                txtElapsedTime.Text = txtResponseTime.Text - txtCommandTime.Text
            End If
        Case comEvSend
        Case comEvCTS
            sMessage = "Change in CTS Detected"
        Case comEvDSR
            sMessage = "Change in DSR Detected"
        Case comEvCD
            sMessage = "Change in CD Detected"
        Case comEvRing
            sMessage = "The Phone is Ringing"
        Case comEvEOF
            sMessage = "End of File Detected"
        ' Error messages.
        Case comBreak
            sMessage = "Break Received"
        Case comCDTO
            sMessage = "Carrier Detect Timeout"
        Case comCTSTO
            sMessage = "CTS Timeout"
        Case comDCB
            sMessage = "Error retrieving DCB"
        Case comDSRTO
            sMessage = "DSR Timeout"
        Case comFrame
            sMessage = "Framing Error"
        Case comOverrun
            sMessage = "Overrun Error"
        Case comRxOver
            sMessage = "Receive Buffer Overflow"
        Case comRxParity
            sMessage = "Parity Error"
        Case comTxFull
            sMessage = "Transmit Buffer Full"
        Case Else
            sMessage = "Unknown error or event"
    End Select
    If sMessage <> "" Then SetStatus (sMessage), False
    GoTo EndOnComm
ErrHandler:
    SetStatus "OnComm: Err " & Err & ". " & Error, True
EndOnComm:
End Sub
Private Sub DisplayToken(NewToken As String)
    Dim TokenIndex As Integer
    
    On Error GoTo ErrHandler
    TokenIndex = 0
    
    Select Case Mid$(NewToken, 1, 1)
        Case "J"
            TokenIndex = 31
            JCounter = JCounter + 1
        Case "U"
            TokenIndex = 17
            'UTime0 = Timer
        Case "K"
            TokenIndex = 17
            'UTime0 = Timer
        Case "!"
            TokenIndex = 1
        Case "#"
            TokenIndex = 2
        Case "$"
            TokenIndex = 3
        Case "&"
            TokenIndex = 4
        Case "*"
            TokenIndex = 5
        Case Chr$(34) ' "
            TokenIndex = 6
        Case "'"
            TokenIndex = 7
        Case "("
            TokenIndex = 8
        Case ","
            TokenIndex = 9
        Case "A"
            TokenIndex = 10
        Case "M"
            TokenIndex = 11
        Case "R"
            TokenIndex = 12
        Case "Z"
            TokenIndex = 13
        Case "E"
            TokenIndex = 14
        Case "O"
            TokenIndex = 15
        Case "T"
            TokenIndex = 16
        Case "F"
            TokenIndex = 18
        Case "X"
            TokenIndex = 19
        Case "^"
            TokenIndex = 20
        Case "G"
            TokenIndex = 21
        Case ")"
            TokenIndex = 22
        Case "D"
            TokenIndex = 23
        Case "H"
            TokenIndex = 24
        Case "I"
            TokenIndex = 25
        Case "S"
            TokenIndex = 26
        Case "V"
            TokenIndex = 27
        Case "Y"
            TokenIndex = 28
        Case "C"
            TokenIndex = 29
        Case "B"
            TokenIndex = 30
        Case "P"
            TokenIndex = 35
        Case "Q"
            Select Case Mid$(NewToken, 2, 1)
                Case "T"
                    TokenIndex = 32
                Case "C"
                    TokenIndex = 34
            End Select
        Case "."
            TokenIndex = 33
        Case Else
            TokenIndex = 0
    End Select
    StatusToken(TokenIndex).Text = NewToken
    GoTo EndDisplayToken
ErrHandler:
    SetStatus "DisplayToken: Err " & Err & ". " & Error, True
EndDisplayToken:
End Sub

Private Sub SetStatus(sStatus As String, bOperation As Boolean)
    txtErrMsg.Text = ""
    txtErrMsg.Text = sStatus
    txtErrMsg.Refresh
End Sub

Private Sub cmdGetAllPorts_Click()
    Dim NumPorts As Long
    Dim i As Integer

    '// Get the Numbers of Ports in the System
    '// and Fill the Ports Structure
    NumPorts = GetAvailablePorts("")
    SetStatus "Getting All Available Ports...", True
    '// Fill the List with the available Ports
    For i = 0 To NumPorts - 1
        SetStatus Ports(i).pPortName, False
    Next
End Sub

Private Sub mnuHelpAbout_Click()
  MsgBox "RT1446Probe by Ken Fowler, KO6NO  "
'  frmAbout.Show vbModal
End Sub

Private Sub mnuFileExit_Click()
  Call form_queryUnload(0, 0)
End Sub

Private Sub form_queryUnload(Cancel As Integer, UnloadMOde As Integer)
    Dim Buffer As String
    
    If MSComm1.InBufferCount > 0 Then Buffer = MSComm1.Input
    If MSComm1.PortOpen = True Then MSComm1.PortOpen = False
    End
End Sub

