Visual Basic Serial Port Communication Routines
Updated:
02/01/09
I often get questions concerning my VB serial port communications routines which are posting on TheScarms Visual Basic Code Library web page. Since I do not have time to answer many of the questions I am posting this example. The example is the complete source code to an Excel Visual Basic Application to program Icom radios through the serial port. The communication routines source code can be found here.
If you have any questions concerning the routines, you may email me but first consider this:
I do not have time to teach you how to program in Visual Basic or how serial ports work. You would be surprised how many requests I get like "Could you please help me to make a program in Visual Basic?".
I do not have time to correct someone else's code or create new sample routines.
If you do write me, please ask a specific question. I do not know how many times I get questions like "I cannot get your routines to work. Please help.".
Main Module
Option Explicit
Public Const MODEL_PRO2006 = &H80
Public Const MODEL_ICR10 = &H52
Public Const MODEL_ICR8500 = &H4A
Public Const MODEL_IC746 = &H56
Public Const MODEL_IC910H = &H60
Public Const MODE_CW = &H301
Public Const MODE_CWN = &H302
Public Const MODE_LSB = &H1
Public Const MODE_USB = &H101
Public Const MODE_AM = &H202
Public Const MODE_NAM = &H203
Public Const MODE_WAM = &H201
Public Const MODE_FM = &H501
Public Const MODE_NFM = &H502
Public Const MODE_WFM = &H601
Public Const VFO_MEMORY = 0
Public Const VFO_A = 1
Public Const VFO_B = 2
Public Const VFO_AB = 3
Public Const VFO_EXCHANGE = 4
Public Const FILTER_NARROW = &H1000
Public Const FILTER_NORMAL = &H2000
Public Const FILTER_WIDE = &H4000
'------------------------------------------------------------------------
' Structures
'------------------------------------------------------------------------
Type MEMORY
lngFreq As Long
lngStep As Long
strMode As String
intAtt As Integer
strName As String
End Type
Dim lngMemories As Long
Dim udtMemories() As MEMORY
Dim lngSearches As Long
Dim udtSearches() As MEMORY
Public blnDebug As Boolean
Public blnSearches As Boolean
Public blnBanks(0 To 19) As Boolean
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Sub ProgramR8500()
Const strTitle As String = "Program R8500"
Dim i As Long
Dim intBank As Integer, intChan As Integer
Dim lngStatus As Long, strTemp As String
Dim intPort As Integer, intCIVAddr As Integer
Dim lngBaudRate As Long, intStepCode As Integer
Dim lngRow As Long, objCells As Object
Dim lngFreq As Long, lngStep As Long
Dim strMode As String, intAtt As Integer
Dim strName As String, strCIV As String
Dim lngFreq1 As Long, lngFreq2 As Long
Dim strTemp1 As String, strTemp2 As String
Dim strBankNames(0 To 19) As String
blnDebug = False
On Error GoTo Routine_Error
SetStatus "Initializing ..."
Set objCells = Sheets("R8500").Cells
intPort = Val(objCells(6, 13).Value)
lngBaudRate = Val(objCells(5, 13).Value)
intCIVAddr = Val("&H" & Trim$(objCells(7, 13).Value))
lngMemories = 0
ReDim udtMemories(0 To 799)
ReDim udtSearches(0 To 19)
SetStatus "Reading Data ..."
' Load Bank Names
lngRow = 4
For i = 0 To 19
strBankNames(i) = CStr(objCells(lngRow, 2).Value)
lngRow = lngRow + 1
Next
' Load Searches
lngRow = 4
For i = 0 To 18 Step 2
' Defaults
lngFreq = 0
strName = ""
strMode = Chr$(&H5) & Chr$(&H1)
lngStep = 5000
intAtt = 0
' Frequency
strTemp1 = Trim$(objCells(lngRow, 5).Value)
strTemp2 = Trim$(objCells(lngRow, 6).Value)
If IsNumeric(strTemp1) And IsNumeric(strTemp2) Then
lngFreq1 = Val(strTemp1) * 1000000
lngFreq2 = Val(strTemp2) * 1000000
' Name
strName = CStr(objCells(lngRow, 7).Value)
' Mode
strTemp = UCase$(Trim$(objCells(lngRow, 8).Value))
Select Case strTemp
' CW = 0301
' CWN = 0302
' LSB = 0001
' USB = 0101
' AM = 0202
' NAM = 0203
' WAM = 0201
' FM = 0501
' NFM = 0502
' WFM = 0601
Case "CW": strMode = Chr$(&H3) & Chr$(&H1)
Case "CWN": strMode = Chr$(&H3) & Chr$(&H2)
Case "LSB": strMode = Chr$(&H0) & Chr$(&H1)
Case "USB": strMode = Chr$(&H1) & Chr$(&H1)
Case "AM": strMode = Chr$(&H2) & Chr$(&H2)
Case "NAM": strMode = Chr$(&H2) & Chr$(&H3)
Case "WAM": strMode = Chr$(&H2) & Chr$(&H1)
Case "FM": strMode = Chr$(&H5) & Chr$(&H1)
Case "NFM": strMode = Chr$(&H5) & Chr$(&H2)
Case "WFM": strMode = Chr$(&H6) & Chr$(&H1)
End Select
' Step
strTemp = Trim$(objCells(lngRow, 9).Value)
If IsNumeric(strTemp) Then
lngStep = Val(strTemp) * 1000
Else
lngStep = 5000
End If
' Attenuator
strTemp = Trim$(objCells(lngRow, 10).Value)
If IsNumeric(strTemp) Then
intAtt = Val(strTemp)
Else
intAtt = 0
End If
If intAtt = 10 Then
intAtt = &H10
ElseIf intAtt = 20 Then
intAtt = &H20
ElseIf intAtt = 30 Then
intAtt = &H30
Else
intAtt = 0
End If
End If
With udtSearches(i)
.lngFreq = lngFreq1
.strName = strName
.strMode = strMode
.lngStep = lngStep
.intAtt = intAtt
End With
With udtSearches(i + 1)
.lngFreq = lngFreq2
.strName = strName
.strMode = strMode
.lngStep = lngStep
.intAtt = intAtt
End With
lngRow = lngRow + 1
Next
Set objCells = Nothing
Set objCells = Sheets("Memories").Cells
lngRow = 3
For i = 0 To 799
' Defaults
lngFreq = 0
strName = ""
strMode = Chr$(&H5) & Chr$(&H1)
lngStep = 5000
intAtt = 0
' Frequency
strTemp = Trim$(objCells(lngRow, 3).Value)
If IsNumeric(strTemp) Then
lngFreq = Val(strTemp) * 1000000
' Name
strName = CStr(objCells(lngRow, 4).Value)
' Mode
strTemp = UCase$(Trim$(objCells(lngRow, 5).Value))
Select Case strTemp
' CW = 0301
' CWN = 0302
' LSB = 0001
' USB = 0101
' AM = 0202
' NAM = 0201
' WAM = 0203
' FM = 0501
' NFM = 0502
' WFM = 0601
Case "CW": strMode = Chr$(&H3) & Chr$(&H1)
Case "CWN": strMode = Chr$(&H3) & Chr$(&H2)
Case "LSB": strMode = Chr$(&H0) & Chr$(&H1)
Case "USB": strMode = Chr$(&H1) & Chr$(&H1)
Case "AM": strMode = Chr$(&H2) & Chr$(&H2)
Case "NAM": strMode = Chr$(&H2) & Chr$(&H3)
Case "WAM": strMode = Chr$(&H2) & Chr$(&H1)
Case "FM": strMode = Chr$(&H5) & Chr$(&H1)
Case "NFM": strMode = Chr$(&H5) & Chr$(&H2)
Case "WFM": strMode = Chr$(&H6) & Chr$(&H1)
End Select
' Step
strTemp = Trim$(objCells(lngRow, 6).Value)
If IsNumeric(strTemp) Then
lngStep = Val(strTemp) * 1000
Else
lngStep = 5000
End If
' Attenuator
strTemp = Trim$(objCells(lngRow, 7).Value)
If IsNumeric(strTemp) Then
intAtt = Val(strTemp)
Else
intAtt = 0
End If
If intAtt = 10 Then
intAtt = &H10
ElseIf intAtt = 20 Then
intAtt = &H20
ElseIf intAtt = 30 Then
intAtt = &H30
Else
intAtt = 0
End If
End If
With udtMemories(i)
.lngFreq = lngFreq
.strName = strName
.strMode = strMode
.lngStep = lngStep
.intAtt = intAtt
End With
lngRow = lngRow + 1
Next
If Not frmProgram.Display("Write Data to R8500") Then GoTo Routine_Exit
Call CIV_Parameters(MODEL_ICR8500, intCIVAddr)
lngStatus = CIV_Initialize(intPort, lngBaudRate)
If lngStatus <> 0 Then
MsgBox "CI-V Initialize Error " & CStr(lngStatus), vbOKOnly, strTitle
GoTo Routine_Exit
End If
For i = 0 To 799
intBank = i \ 40
intChan = i - (intBank * 40)
If blnBanks(intBank) Then
SetStatus "Writing Bank " & Format$(intBank, "00") & _
" Chan " & Format$(intChan, "000") & " ..."
If intChan = 0 Then
' Write Bank Name
strName = strBankNames(intBank)
If Len(strName) > 5 Then
strName = Left$(strName, 5)
ElseIf Len(strName) < 5 Then
strName = strName & Space$(5 - Len(strName))
End If
strCIV = IntToBCD(intBank, 1) & strName
If Not CIV_WriteCommand(&H1A, 2, strCIV, 100) Then
MsgBox "CIV Write Error!", vbOKOnly, strTitle
GoTo CIV_Close
Else
If ReadResponse(500) <> 1 Then
MsgBox "Response Error! Bank: " & CStr(intBank), _
vbOKOnly, strTitle
GoTo CIV_Close
End If
End If
Sleep 500
End If
If Not WriteMemory(intBank, intChan, udtMemories(i)) Then _
GoTo CIV_Close
If intChan = 0 Then
If Not WriteMemory(intBank, intChan, udtMemories(i)) Then _
GoTo CIV_Close
End If
End If
Next
If blnSearches Then
For intChan = 0 To 19
SetStatus "Writing Search " & Format$(intChan / 2, "00") & " ..."
If Not WriteMemory(23, intChan, udtSearches(intChan)) Then _
GoTo CIV_Close
Next
End If
CIV_Close:
Call CIV_Reset
Routine_Exit:
If blnDebug Then If Not frmDebug.Visible Then frmDebug.Show
SetStatus "Program Complete"
Exit Sub
Routine_Error:
MsgBox "Program Error (" & CStr(Err) & "): " & Err.Description, _
vbOKOnly, strTitle
Resume Routine_Exit
End Sub
Public Sub SetStatus(strMessage As String)
Application.StatusBar = strMessage
DoEvents
End Sub
Private Function WriteMemory(intBank As Integer, intChan As Integer, _
udtMemory As MEMORY) As Boolean
Const strTitle As String = "Write Memory"
Dim lngFreq As Long, lngStep As Long
Dim strMode As String, intAtt As Integer
Dim strName As String, strCIV As String
Dim intStepCode As Integer
With udtMemory
lngFreq = .lngFreq
strName = .strName
strMode = .strMode
lngStep = .lngStep
intAtt = .intAtt
End With
If lngFreq = 0 Then
Call CIV_ClearMemory(intBank, intChan)
Else
If blnDebug Then
frmDebug.DebugWrite 1, 1, "FE FE 4A E0 1A 00 BN M1 M2 " & _
"F1 F2 F3 F4 F5 MO FI TS T1 T2 AT SC " & _
"N1 N2 N3 N4 N5 N6 N7 N8 FD"
End If
strCIV = IntToBCD(intBank, 1) & IntToBCD(intChan, 2)
Call CIV_ReadCommand(&H1A, 1, strCIV, 100)
' Bank and Channel
strCIV = IntToBCD(intBank, 1) & IntToBCD(intChan, 2)
' Frequency
strCIV = strCIV & LongToBCDR(lngFreq, 5)
' Mode
strCIV = strCIV & strMode
' Step
Select Case lngStep
Case 10: intStepCode = 0
Case 50: intStepCode = 1
Case 100: intStepCode = 2
Case 1000: intStepCode = 3
Case 2500: intStepCode = 4
Case 5000: intStepCode = 5
Case 9000: intStepCode = 6
Case 10000: intStepCode = 7
Case 12500: intStepCode = 8
Case 20000: intStepCode = 9
Case 25000: intStepCode = 10
Case 100000: intStepCode = 11
Case 1000000: intStepCode = 12
Case Else
intStepCode = 13
End Select
If (intStepCode = 13) And _
((lngStep < 500) Or (lngStep > 199.5)) Then
intStepCode = 3
MsgBox "Invalid Step!" & vbCrLf & "Bank: " & CStr(intBank) & _
" Channel: " & CStr(intChan), vbOKOnly, strTitle
End If
strCIV = strCIV & IntToBCD(intStepCode, 1)
If intStepCode = 13 Then
strCIV = strCIV & LongToBCD(lngStep / 10, 2)
Else
strCIV = strCIV & LongToBCD(5, 2)
End If
' Attenuator
strCIV = strCIV & Chr$(intAtt)
' Scan / Skip
strCIV = strCIV & IntToBCD(0, 1)
' Name
If Len(strName) > 8 Then
strName = Left$(strName, 8)
ElseIf Len(strName) < 8 Then
strName = strName & Space$(8 - Len(strName))
End If
strCIV = strCIV & strName
If Not CIV_WriteCommand(&H1A, 0, strCIV, 100) Then
MsgBox "CIV Write Error!", vbOKOnly, strTitle
GoTo Routine_Abort
Else
If ReadResponse(500) <> 1 Then
MsgBox "Response Error! Bank: " & CStr(intBank) & _
" Channel: " & CStr(intChan), vbOKOnly, strTitle
GoTo Routine_Abort
End If
End If
End If
WriteMemory = True
Routine_Exit:
Exit Function
Routine_Abort:
WriteMemory = False
GoTo Routine_Exit
Routine_Error:
WriteMemory = False
MsgBox "Program Error (" & CStr(Err) & "): " & Err.Description & _
vbCrLf & "Bank: " & CStr(intBank) & _
" Channel: " & CStr(intChan), vbOKOnly, strTitle
Resume Routine_Exit
End Function
Timer Module
Option Explicit
Private Const strModule As String = "modHRTimer"
Type HR_TIMER
blnActive As Boolean
blnAllocated As Boolean
lngExpiration As Long
End Type
Private intTimerCount As Integer
Private udtTimers() As HR_TIMER
Declare Function timeGetTime Lib "winmm.dll" () As Long
'----------------------------------------------------------------------
' AllocTimer - Allocates a new timer slot.
'----------------------------------------------------------------------
Public Function AllocTimer() As Integer
Dim i As Integer
Dim intHandle As Integer
On Error GoTo AllocTimer_Error
intHandle = -1
For i = 0 To intTimerCount - 1
If Not udtTimers(i).blnAllocated Then
AllocTimer = i
udtTimers(i).blnAllocated = True
GoTo AllocTimer_Exit
End If
Next
ReDim Preserve udtTimers(intTimerCount)
AllocTimer = intTimerCount
udtTimers(intTimerCount).blnAllocated = True
intTimerCount = intTimerCount + 1
AllocTimer_Exit:
Exit Function
AllocTimer_Error:
AllocTimer = -1
Resume AllocTimer_Exit
End Function
'----------------------------------------------------------------------
' TimerStart - Starts a second timer.
'
' TimerID - Timer ID 0 - 9
' Secs - Timer duration in seconds.
'----------------------------------------------------------------------
Sub TimerStart(intTimerID As Integer, lngSecs As Long)
udtTimers(intTimerID).blnActive = True
udtTimers(intTimerID).lngExpiration = timeGetTime + (lngSecs * 1000)
End Sub
'----------------------------------------------------------------------
' MSTimerStart - Starts a millisecond timer.
'
' TimerID - Timer ID 0 - 9
' MSecs - Timer duration in milliseconds.
'----------------------------------------------------------------------
Public Sub MSTimerStart(intTimerID As Integer, lngMSecs As Long)
udtTimers(intTimerID).blnActive = True
udtTimers(intTimerID).lngExpiration = timeGetTime + lngMSecs
End Sub
'----------------------------------------------------------------------*
' TimerCheck - Tests a timer to see if that timer has expired.
'
' Returns: TRUE - Timer has expired.
' FALSE - Timer is still running.
'----------------------------------------------------------------------*/
Function TimerCheck(intTimerID As Integer) As Boolean
Dim lngTime As Long
On Error GoTo TimerCheck_Error
If Not udtTimers(intTimerID).blnActive Then
TimerCheck = True
Exit Function
End If
lngTime = timeGetTime
If lngTime = 0 Or lngTime >= udtTimers(intTimerID).lngExpiration Then
TimerCheck = True
udtTimers(intTimerID).blnActive = False
Exit Function
End If
TimerCheck = False
TimerCheck_Exit:
Exit Function
TimerCheck_Error:
' Set timer to expired on errors so code will not hang.
TimerCheck = True
Resume TimerCheck_Exit
End Function
'----------------------------------------------------------------------
' FreeTimer - Frees an allocated timer slot.
'----------------------------------------------------------------------
Public Sub FreeTimer(intTimerID As Integer)
If intTimerID < 0 Or intTimerID >= intTimerCount Then Exit Sub
udtTimers(intTimerID).blnActive = False
udtTimers(intTimerID).blnAllocated = False
End Sub
CIV Module
Option Explicit
' IC-746
' P1 = 100, P2 = 101
' C = 102
'
' IC-910H
' 1A = 100, 1B = 101
' 2A = 102, 2B = 103
' 3A = 104, 3B = 105
' C = 106
Private intPortID As Integer
Private intRadioType As Integer
Private blnInFunction As Boolean
Private blnInitialized As Boolean
Private intTimeoutTimer As Integer
Private intCommandTimer As Integer
Private lngFreqLo As Long
Private lngFreqHi As Long
Private CivBlank As String
Private CivOK As String
Private CivNG As String
Private CivRcvAddr As String
Private CivSync As String
Private CivTerm As String
Private CivTrnAddr As String
Public Function CIV_WriteCommand(intCmd As Integer, intSub As Integer, _
strData As String, lngTimeout As Long) As Boolean
Dim strRcv As String
Dim strPacket As String
CIV_WriteCommand = False
While Not TimerCheck(intCommandTimer)
DoEvents
Wend
If intSub = -1 Then
' FE FE RA TA CN data FD
strPacket = CivSync & CivRcvAddr & CivTrnAddr & _
Chr$(intCmd) & strData & CivTerm
Else
' FE FE RA TA CN SC data FD
strPacket = CivSync & CivRcvAddr & CivTrnAddr & _
Chr$(intCmd) & Chr$(intSub) & strData & CivTerm
End If
If blnDebug Then frmDebug.DebugHex intPortID, 0, strPacket
If CommFlush(intPortID) <> 0 Then Exit Function
If CommWrite(intPortID, strPacket) <> Len(strPacket) Then Exit Function
' Start command spacing timer.
MSTimerStart intCommandTimer, 50
CIV_WriteCommand = True
End Function
Public Function CIV_ReadCommand(intCmd As Integer, intSub As Integer, _
strData As String, lngTimeout As Long) As Integer
Dim intPos As Integer
Dim strPacket As String
Dim intSize As Integer, intMinResp As Integer
Dim blnError As Boolean, lngStatus As Long
strPacket = ""
blnError = False
CIV_ReadCommand = 0
If intSub = -1 Then
' FE FE TA RA CN data FD
intMinResp = 7
Else
' FE FE TA RA CN SC data FD
intMinResp = 8
End If
' Send command to read data.
If Not CIV_WriteCommand(intCmd, intSub, strData, lngTimeout) Then _
Exit Function
' Read echoed command.
MSTimerStart intTimeoutTimer, lngTimeout
Do
lngStatus = CommRead(intPortID, strData, 32)
If lngStatus < 0 Then
blnError = True
If blnDebug Then frmDebug.lblError = "Error: " & CStr(lngStatus)
Exit Do
ElseIf lngStatus = 0 Then
' No data.
If TimerCheck(intTimeoutTimer) Then
blnError = True
If blnDebug Then frmDebug.lblError = "Timeout"
Exit Do
End If
Sleep 10
Else
' Got data.
strPacket = strPacket & strData
If InStr(1, strPacket, CivTerm) > 0 Then Exit Do
End If
Loop
If blnError Then Exit Function
If blnDebug Then frmDebug.DebugHex 1, 1, strPacket
' We may have gotten some of the returned data so save it.
intPos = InStr(strPacket, CivTerm)
If Len(strPacket) > intPos Then
strPacket = Mid$(strPacket, intPos + 1)
Else
strPacket = ""
End If
' Read returned data.
MSTimerStart intTimeoutTimer, lngTimeout
Do
lngStatus = CommRead(intPortID, strData, 32)
If lngStatus < 0 Then
blnError = True
If blnDebug Then frmDebug.lblError = "Error: " & CStr(lngStatus)
Exit Do
ElseIf lngStatus = 0 Then
' No data.
If TimerCheck(intTimeoutTimer) Then
blnError = True
If blnDebug Then frmDebug.lblError = "Timeout"
Exit Do
End If
Sleep 10
Else
' Got data.
strPacket = strPacket & strData
If InStr(1, strPacket, CivTerm) > 0 Then Exit Do
End If
Loop
If blnError Then Exit Function
If blnDebug Then frmDebug.DebugHex 1, 1, strPacket
' Make sure data is in sync.
intPos = InStr(1, strPacket, CivSync)
If intPos > 1 Then strPacket = Mid$(strPacket, intPos)
' Get the size of the returned command.
intSize = InStr(1, strPacket, CivTerm)
If intSize < intMinResp Then Exit Function
' Extract data.
strData = Mid$(strPacket, intMinResp - 1, intSize - intMinResp + 1)
CIV_ReadCommand = Len(strData)
End Function
Public Function ReadResponse(lngTimeout As Long) As Integer
Dim strRcv As String
ReadResponse = -1
Call MSTimerStart(intTimeoutTimer, lngTimeout)
Do
If CommRead(intPortID, strRcv, 32) > 0 Then
If InStr(1, strRcv, CivOK) > 0 Then
If blnDebug Then frmDebug.DebugHex intPortID, 1, strRcv
ReadResponse = 1
Exit Function
ElseIf InStr(1, strRcv, CivNG) > 0 Then
If blnDebug Then frmDebug.DebugHex intPortID, 1, strRcv
ReadResponse = 0
Exit Function
End If
End If
If TimerCheck(intTimeoutTimer) Then Exit Function
Loop
End Function
'-------------------------------
' Bytes are placed in order.
'
' 1234 => 12 34
'-------------------------------
Public Function IntToBCD(intValue As Integer, intBytes As Integer) As String
Dim strData As String
Dim i As Integer, c As Integer, intDigit As Integer
Dim intDivisor As Integer, intTemp As Integer
intTemp = intValue
If intBytes = 1 Then
intDivisor = 10
ElseIf intBytes = 2 Then
intDivisor = 1000
Else
IntToBCD = ""
Exit Function
End If
strData = Space(intBytes)
For i = 1 To intBytes
' High nibble.
intDigit = intTemp \ intDivisor ' Integer Divide
intTemp = intTemp - (intDigit * intDivisor)
c = (intDigit * 16) And &HF0
intDivisor = intDivisor / 10
' Low nibble.
intDigit = intTemp \ intDivisor
intTemp = intTemp - (intDigit * intDivisor)
Mid(strData, i, 1) = Chr$(c + intDigit)
intDivisor = intDivisor / 10
Next
IntToBCD = strData
End Function
'-------------------------------
' Bytes are placed in order.
'
' 1234 => 12 34
'-------------------------------
Public Function LongToBCD(lngValue As Long, intBytes As Integer) As String
Dim strData As String
Dim i As Long, c As Long, lngDigit As Long
Dim lngDivisor As Long, lngTemp As Long
lngTemp = lngValue
If intBytes = 1 Then
lngDivisor = 10
ElseIf intBytes = 2 Then
lngDivisor = 1000
Else
LongToBCD = ""
Exit Function
End If
strData = Space(intBytes)
For i = 1 To intBytes
' High nibble.
lngDigit = lngTemp \ lngDivisor ' Integer Divide
lngTemp = lngTemp - (lngDigit * lngDivisor)
c = (lngDigit * 16) And &HF0
lngDivisor = lngDivisor / 10
' Low nibble.
lngDigit = lngTemp \ lngDivisor
lngTemp = lngTemp - (lngDigit * lngDivisor)
Mid(strData, i, 1) = Chr$(c + lngDigit)
lngDivisor = lngDivisor / 10
Next
LongToBCD = strData
End Function
'----------------------------------------
' Bytes are placed in reverse order.
'
' 123456 => 56 34 12
'----------------------------------------
Public Function LongToBCDR(lngValue As Long, intBytes As Integer) As String
Dim strData As String
Dim lngDivisor As Long, lngTemp As Long
Dim i As Integer, c As Integer, intDigit As Integer
lngTemp = lngValue
If intBytes = 2 Then
lngDivisor = 1000
ElseIf intBytes = 3 Then ' Normally used for step.
lngDivisor = 100000
ElseIf intBytes = 4 Then
lngDivisor = 10000000
ElseIf intBytes = 5 Then
lngDivisor = 1000000000 ' Normally used for freq.
Else
LongToBCDR = ""
Exit Function
End If
strData = Space(intBytes)
For i = intBytes To 1 Step -1
intDigit = lngTemp \ lngDivisor ' Integer Divide
lngTemp = lngTemp - (intDigit * lngDivisor)
c = (intDigit * 16) And &HF0
lngDivisor = lngDivisor / 10
intDigit = lngTemp \ lngDivisor
lngTemp = lngTemp - (intDigit * lngDivisor)
Mid(strData, i, 1) = Chr$(c + intDigit)
lngDivisor = lngDivisor / 10
Next
LongToBCDR = strData
End Function
Public Function BCDToLong(strData As String) As Long
Dim i As Integer
Dim intChr As Integer
Dim intSize As Integer
Dim lngByte As Long, lngValue As Long
Dim lngM1 As Long, lngMult As Long
lngMult = 1
lngValue = 0
intSize = Len(strData)
For i = intSize To 1 Step -1
intChr = Asc(Mid$(strData, i, 1))
lngByte = ((intChr And &HF0) / 16 * 10) + (intChr And &HF)
lngValue = (lngValue * lngMult) + lngByte
lngMult = 100
Next
BCDToLong = lngValue
End Function
Private Sub CIV_Address(ByVal lngAddress As Long)
CivRcvAddr = Chr$(lngAddress)
End Sub
Public Sub CIV_SetFrequency(ByVal lngFrequency As Long)
If blnInFunction Then Exit Sub
If lngFrequency < lngFreqLo Or lngFrequency > lngFreqHi Then Exit Sub
blnInFunction = True
Call CIV_WriteCommand(&H0, -1, LongToBCDR(lngFrequency, 5), 100)
blnInFunction = False
End Sub
Public Sub CIV_SetChannel(ByVal intChannel As Integer)
If blnInFunction Then Exit Sub
blnInFunction = True
Call CIV_WriteCommand(&H8, -1, IntToBCD(intChannel, 2), 100)
blnInFunction = False
End Sub
Public Sub CIV_SetVFO(ByVal intMode As Integer)
If blnInFunction Then Exit Sub
blnInFunction = True
' Set VFO mode.
If intMode = VFO_MEMORY Then
Call CIV_WriteCommand(&H8, -1, "", 100)
ElseIf intMode = VFO_A Then
Call CIV_WriteCommand(&H7, &H0, "", 100)
ElseIf intMode = VFO_B Then
Call CIV_WriteCommand(&H7, &H1, "", 100)
ElseIf intMode = VFO_AB Then
Call CIV_WriteCommand(&H7, &HA0, "", 100)
ElseIf intMode = VFO_EXCHANGE Then
Call CIV_WriteCommand(&H7, &HB0, "", 100)
End If
blnInFunction = False
End Sub
Public Sub CIV_WriteToMemory(ByVal intChannel As Integer)
If blnInFunction Then Exit Sub
blnInFunction = True
Call CIV_WriteCommand(&H8, -1, IntToBCD(intChannel, 2), 100)
Call CIV_WriteCommand(&H9, -1, "", 100)
blnInFunction = False
End Sub
Public Sub CIV_ClearMemory(ByVal intBank As Integer, ByVal intChan As Integer)
If blnInFunction Then Exit Sub
blnInFunction = True
Call CIV_WriteCommand(&H8, &HA0, IntToBCD(intBank, 1), 100)
Call CIV_WriteCommand(&H8, -1, IntToBCD(intChan, 2), 100)
Call CIV_WriteCommand(&HB, -1, "", 100)
blnInFunction = False
End Sub
Public Sub CIV_SetTone(ByVal blnOn As Boolean, ByVal intFrequency As Integer)
Dim strData As String
If blnInFunction Then Exit Sub
blnInFunction = True
If blnOn Then
strData = Chr$(1)
Call CIV_WriteCommand(&H16, &H42, strData, 100)
Call CIV_WriteCommand(&H1B, &H0, IntToBCD(intFrequency, 2), 100)
Else
strData = Chr$(0)
Call CIV_WriteCommand(&H16, &H42, strData, 100)
End If
blnInFunction = False
End Sub
Public Sub CIV_SetToneSQL(ByVal blnOn As Boolean, ByVal intFrequency As Integer)
Dim strData As String
If blnInFunction Then Exit Sub
blnInFunction = True
If blnOn Then
strData = Chr$(1)
Call CIV_WriteCommand(&H16, &H43, strData, 100)
Call CIV_WriteCommand(&H1B, &H1, IntToBCD(intFrequency, 2), 100)
Else
strData = Chr$(0)
Call CIV_WriteCommand(&H16, &H43, strData, 100)
End If
blnInFunction = False
End Sub
Private Function CIV_GetFrequency() As Long
Dim strData As String
Dim lngFrequency As Long
CIV_GetFrequency = 0
If blnInFunction Then Exit Function
blnInFunction = True
If CIV_ReadCommand(&H3, -1, strData, 100) <> 5 Then GoTo Routine_Exit
CIV_GetFrequency = BCDToLong(strData)
Routine_Exit:
blnInFunction = False
End Function
Public Function CIV_Initialize(intCommPort As Integer, lngBaudRate As Long) As Long
Dim lngStatus As Long
Dim strCommName As String
On Error GoTo Routine_Error
CIV_Initialize = 0
On Error GoTo Routine_Error
If blnInitialized Then Exit Function
intPortID = intCommPort
strCommName = "COM" & CStr(intCommPort)
CivSync = Chr$(&HFE) & Chr$(&HFE)
CivTerm = Chr$(&HFD)
CivTrnAddr = Chr$(&HE0)
CivOK = Chr$(&HFB)
CivNG = Chr$(&HFA)
CivBlank = Chr$(&HFF)
lngStatus = CommOpen(intPortID, strCommName, CStr(lngBaudRate) & ",N,8,1")
If lngStatus Then
CIV_Initialize = lngStatus
GoTo Routine_Exit
End If
intTimeoutTimer = AllocTimer
intCommandTimer = AllocTimer
blnInitialized = True
Routine_Exit:
Exit Function
Routine_Error:
CIV_Initialize = Err.Number
Resume Routine_Exit
End Function
Private Function CIV_Initialized() As Boolean
CIV_Initialized = blnInitialized
End Function
Public Sub CIV_SetMode(ByVal intMode As Integer)
Dim intSub As Integer
Dim strData As String
If blnInFunction Then Exit Sub
blnInFunction = True
If intRadioType = MODEL_ICR8500 Then
If intMode And MODE_CW Then
intSub = &H3
If intMode And FILTER_NARROW Then
strData = Chr$(&H2)
Else
strData = Chr$(&H1)
End If
ElseIf intMode And MODE_LSB Then
intSub = &H0
strData = Chr$(&H1)
ElseIf intMode And MODE_USB Then
intSub = &H1
strData = Chr$(&H1)
ElseIf intMode And MODE_AM Then
intSub = &H2
If intMode And FILTER_NARROW Then
strData = Chr$(&H3)
ElseIf intMode And FILTER_WIDE Then
strData = Chr$(&H1)
Else
strData = Chr$(&H2)
End If
ElseIf intMode And MODE_FM Then
If intMode And FILTER_NARROW Then
intSub = &H5
strData = Chr$(&H2)
ElseIf intMode And FILTER_WIDE Then
intSub = &H6
strData = Chr$(&H1)
Else
intSub = &H5
strData = Chr$(&H1)
End If
End If
Call CIV_WriteCommand(&H6, intSub, strData, 100)
Else
If intMode And MODE_CW Then
intSub = &H3
ElseIf intMode And MODE_LSB Then
intSub = &H0
ElseIf intMode And MODE_USB Then
intSub = &H1
ElseIf intMode And MODE_AM Then
intSub = &H2
ElseIf intMode And MODE_FM Then
intSub = &H5
End If
If intMode And FILTER_NARROW Then
strData = Chr$(&H2)
Else
strData = Chr$(&H1)
End If
Call CIV_WriteCommand(&H1, intSub, strData, 100)
End If
blnInFunction = False
End Sub
Private Function CIV_GetMode() As Integer
Dim strData As String
Dim intRadioMode As Integer
Dim intMode As Integer, intFilter As Integer
CIV_GetMode = 0
If blnInFunction Then Exit Function
blnInFunction = True
Select Case intRadioType
Case MODEL_ICR8500
If CIV_ReadCommand(&H4, -1, strData, 100) <> 2 Then GoTo Routine_Exit
intMode = Asc(Mid$(strData, 1, 1))
intFilter = Asc(Mid$(strData, 2, 1))
If intMode = 0 And intFilter = 1 Then
intRadioMode = MODE_LSB Or FILTER_NORMAL
ElseIf intMode = 1 And intFilter = 1 Then
intRadioMode = MODE_USB Or FILTER_NORMAL
ElseIf intMode = 2 Then
If intFilter = 1 Then
intRadioMode = MODE_AM Or FILTER_WIDE
ElseIf intFilter = 2 Then
intRadioMode = MODE_AM Or FILTER_NORMAL
ElseIf intFilter = 3 Then
intRadioMode = MODE_AM Or FILTER_NARROW
End If
ElseIf intMode = 3 Then
If intFilter = 1 Then
intRadioMode = MODE_CW Or FILTER_NORMAL
ElseIf intFilter = 2 Then
intRadioMode = MODE_CW Or FILTER_NARROW
End If
ElseIf intMode = 5 Then
If intFilter = 1 Then
intRadioMode = MODE_FM Or FILTER_NORMAL
ElseIf intFilter = 2 Then
intRadioMode = MODE_FM Or FILTER_NARROW
End If
ElseIf intMode = 6 And intFilter = 1 Then
intRadioMode = MODE_FM Or FILTER_WIDE
End If
End Select
CIV_GetMode = intRadioMode
Routine_Exit:
blnInFunction = False
End Function
Public Function CIV_Parameters(lngRadioType As Long, intCIVAddress As Integer) As Boolean
intRadioType = lngRadioType ' P1 = Radio Type
CivRcvAddr = Chr$(intCIVAddress) ' P2 = CIV Address
Select Case intRadioType
Case MODEL_PRO2006:
lngFreqLo = 25000000
lngFreqHi = 1300000000
Case MODEL_ICR10:
lngFreqLo = 500000
lngFreqHi = 1300000000
Case MODEL_ICR8500:
lngFreqLo = 100000
lngFreqHi = 1999999990
Case MODEL_IC746:
lngFreqLo = 30000
lngFreqHi = 174000000
Case MODEL_IC910H:
lngFreqLo = 136000000
lngFreqHi = 1320000000
End Select
End Function
Public Function CIV_Reset() As Long
Dim lngStatus As Integer
On Error GoTo Routine_Error
FreeTimer intTimeoutTimer
CIV_Reset = CommClose(intPortID)
blnInitialized = False
Routine_Exit:
Exit Function
Routine_Error:
CIV_Reset = Err.Number
Resume Routine_Exit
End Function