serport.bas

Serial Port Complete, Programming and Circuits for RS-232 and RS-485 Links and Networks

Dim handle As Long
'The API call requires a CommID of an open port.
If frmMain.MSComm1.PortOpen = False Then
    frmMain.MSComm1.PortOpen = True
    ClosePortOnExit = True
Else
    ClosePortOnExit = False
End If
handle = frmMain.MSComm1.CommID
PortCount = GETMAXCOM
'Add 1 because EscapeCommFunction begins counting at 0.
fncGetHighestComPortNumber = _
    EscapeCommFunction(handle, PortCount) + 1
If ClosePortOnExit = True Then
    frmMain.MSComm1.PortOpen = False
End If
End Function

Public Function fncOneByteDelay(BitRate As Long) As Single
'Calculate the time in milliseconds to transmit
'8 bits + 1 Start & 1 Stop bit.
Dim DelayTime As Integer
DelayTime = 10000 / BitRate
fncOneByteDelay = DelayTime
End Function

Public Function fncVerifyChecksum(UserString As String) As Boolean
'Verifies data by comparing a received checksum
'to the calculated value.
'UserString is a series of bytes in Ascii Hex format,
'Ending in a checksum.
Dim Count As Integer
Dim Sum As Long
Dim Checksum As Byte
Dim ChecksumAsAsciiHex As String
'Add the values of each Ascii Hex pair:
For Count = 1 To Len(UserString) - 3 Step 2
    Sum = Sum + Val("&h" & Mid(UserString, Count, 2))
Next Count
'The checksum is the low byte of the sum.
Checksum = Sum - (CInt(Sum / 256)) * 256
ChecksumAsAsciiHex = fncByteToAsciiHex(Checksum)
'Compare the calculated checksum to the received checksum.
If Checksum = Val("&h" & (Right(UserString, 2))) Then
    fncVerifyChecksum = True
Else
    fncVerifyChecksum = False
End If
End Function

Public Sub Delay(DelayInMilliseconds As Single)
'Delay timer with approximately 1-msec. resolution.
'Uses the API function timeGetTime.
'Rolls over 24 days after the last Windows startup.
Dim Timeout As Single
Timeout = DelayInMilliseconds + timeGetTime()
Do Until timeGetTime() >= Timeout
    DoEvents
Loop
End Sub

Public Sub EditDCB()
'Enables changes to a port's DCB.
'The port must be open.
Dim Success As Boolean
Dim PortID As Long
PortID = frmMain.MSComm1.CommID
Success = apiGetCommState(PortID, CommDCB)

'To change a value, uncomment and revise the appropriate line:
'CommDCB.BaudRate = 2400
'CommDCB.Bits1 = &H11
'CommDCB.XonLim = 64
'CommDCB.XoffLim = 64
'CommDCB.ByteSize = 8
'CommDCB.Parity = 0
'CommDCB.StopBits = 0
'CommDCB.XonChar = &H12
'CommDCB.XoffChar = &H13
'CommDCB.ErrorChar = 0
'CommDCB.EofChar = &H1A
'CommDCB.EvtChar = 0

'Write the values to the DCB.
Success = apiSetCommState(PortID, CommDCB)

'Read the values back to verify changes.
Success = apiGetCommState(PortID, CommDCB)

Debug.Print "DCBlength: ", Hex$(CommDCB.DCBlength)
Debug.Print "BaudRate: ", CommDCB.BaudRate
Debug.Print "Bits1: ", Hex$(CommDCB.Bits1); "h"
Debug.Print "wReserved: ", Hex$(CommDCB.wReserved)
Debug.Print "XonLim: ", CommDCB.XonLim
Debug.Print "XoffLim: ", CommDCB.XoffLim
Debug.Print "ByteSize: ", CommDCB.ByteSize
Debug.Print "Parity: ", CommDCB.Parity
Debug.Print "StopBits: ", CommDCB.StopBits
Debug.Print "XonChar: ", Hex$(CommDCB.XonChar); "h"
Debug.Print "XoffChar: ", Hex$(CommDCB.XoffChar); "h"
Debug.Print "ErrorChar: ", Hex$(CommDCB.ErrorChar); "h"
Debug.Print "EofChar: ", Hex$(CommDCB.EofChar); "h"
Debug.Print "EvtChar: ", Hex$(CommDCB.EvtChar); "h"
Debug.Print "wReserved2: ", Hex$(CommDCB.wReserved2)

End Sub

Public Sub FindPorts()
'Find Comm ports by trying to open each.
'Each port must support the current settings (bit rate, etc.).
Dim Count As Integer
Dim NumberOfPorts As Integer
Dim SavedPortNumber As Integer
Dim SaveCurrentPort As Boolean
ReDim CommPorts(1 To 16)
On Error Resume Next
SaveCurrentPort = False
NumberOfPorts = 0
'If a port is already open, reopen it on exiting.
If frmMain.MSComm1.PortOpen = True Then
        frmMain.MSComm1.PortOpen = False
        SavedPortNumber = PortNumber
        SaveCurrentPort = True
End If
For Count = 1 To 16
    frmMain.MSComm1.CommPort = Count
    frmMain.MSComm1.PortOpen = True
    If Err.Number = 8005 Then
        'The port is already open
        'The port exists, so add it to the list.
        NumberOfPorts = NumberOfPorts + 1
        CommPorts(NumberOfPorts) = "COM" & CStr(Count)
    ElseIf frmMain.MSComm1.PortOpen = True Then
        'If the port opens, it exists.
        'Close it and add to the list.
        frmMain.MSComm1.PortOpen = False
        NumberOfPorts = NumberOfPorts + 1
        CommPorts(NumberOfPorts) = "COM" & CStr(Count)
    Err.Clear
    End If
Next Count
'Disable the error handler
On Error GoTo 0
ReDim Preserve CommPorts(1 To NumberOfPorts)
If SaveCurrentPort = True Then
    PortNumber = SavedPortNumber
    frmMain.MSComm1.CommPort = PortNumber
    frmMain.MSComm1.PortOpen = True
End If
End Sub

Public Sub GetNewSettings()
'Read and store user changes in the Setup menu.
BitRate = Val(frmPortSettings.cboBitRate.Text)
PortNumber = Val(Right(frmPortSettings.cboPort.Text, 1))
Call frmMain.fncInitializeComPort(BitRate, PortNumber)
End Sub

Public Sub GetSettings()
'Get user settings from last time.
BitRate = GetSetting(ProjectName, "Startup", "BitRate", 1200)
PortNumber = GetSetting(ProjectName, "Startup", "PortNumber", 1)
'Defaults in case values retrieved are invalid:
If BitRate < 300 Then BitRate = 9600
If PortNumber < 1 Then PortNumber = 1
End Sub

Sub ImmediateTransmit(ByteToSend As Byte)
'Places a byte at the top of the transmit buffer
'for immediate sending.
Dim Success As Boolean
Success = TransmitCommChar(frmMain.MSComm1.CommID, ByteToSend)
End Sub

Public Sub LowResDelay(DelayInMilliseconds As Single)
'Uses the system timer, with resolution of about 56 milliseconds.
Dim Timeout As Single
'Add the delay to the current time.
Timeout = Timer + DelayInMilliseconds / 1000
If Timeout > 86399 Then
    'If the end of the delay spans midnight,
    'subtract 24 hrs. from the Timeout count:
    Timeout = Timeout - 86399
    'and wait for midnight:
    Do Until Timer < 100
        DoEvents
    Loop
End If
'Wait for the Timeout count.
Do Until Timer >= Timeout
    DoEvents
Loop
End Sub

Public Sub SaveSettings()
'Save user settings for next time.
SaveSetting ProjectName, "Startup", "BitRate", BitRate
SaveSetting ProjectName, "Startup", "PortNumber", PortNumber
End Sub

Public Sub ShutDown()
'Close the port.
If frmMain.MSComm1.PortOpen = True Then
    frmMain.MSComm1.PortOpen = False
End If
Call SaveSettings
End Sub

Public Sub Startup()
Call GetSettings
PortOpen = frmMain.fncInitializeComPort(BitRate, PortNumber)
Call frmPortSettings.SetBitRateComboBox
Call frmPortSettings.SetPortComboBox
Call VbSetCommTimeouts(BitRate)
If ValidPort = False Then
    frmPortSettings.Show
Else
    frmPortSettings.Hide
End If
End Sub

Public Sub VbSetCommTimeouts(BitRate As Long)
'The default timeout for serial-port operations is 5 seconds.
'This routine sets the timeout so that
'the requested number of bytes can transmit or be read
'at the current bit rate.
'Uses the GetCommTimeouts and SetCommTimeouts API functions.
Dim Timeouts As COMMTIMEOUTS
Dim Success As Long
Dim OneByteTimeout As Long
Success = GetCommTimeouts(frmMain.MSComm1.CommID, Timeouts)
OneByteTimeout = CLng(fncOneByteDelay(BitRate))
If frmMain.MSComm1.PortOpen = True Then
    'All values are milliseconds
    'Maximum time between two received characters:
    Timeouts.ReadIntervalTimeout = OneByteTimeout
    'Maximum time for a character to arrive:
    Timeouts.ReadTotalTimoutMultiplier = OneByteTimeout
    'Provide enough time for the bytes to arrive + 1 second.
    Timeouts.ReadTotalTimeoutConstant = 1000
    'Maximum time for a character to transmit:
    Timeouts.WriteTotalTimeoutMultiplier = OneByteTimeout
    'Provide enough time for the bytes to transmit + 1 second.
    Timeouts.WriteTotalTimeoutConstant = 1000
    Success = SetCommTimeouts(frmMain.MSComm1.CommID, Timeouts)
End If
'For debugging/verifying:
'Success = GetCommTimeouts(frmMain.MSComm1.CommID, Timeouts)
'Debug.Print Timeouts.ReadIntervalTimeout
'Debug.Print Timeouts.ReadTotalTimoutMultiplier
'Debug.Print Timeouts.ReadTotalTimeoutConstant
'Debug.Print Timeouts.WriteTotalTimeoutMultiplier
'Debug.Print Timeouts.WriteTotalTimeoutConstant
End Sub