Option Explicit
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function CreateFile Lib "kernel32.dll" Alias "CreateFileA" ( _
ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, _
lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const OPEN_EXISTING = &H3
Private Const OPEN_ALWAYS = &H4
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const INVALID_HANDLE_VALUE = -1
Private Const FirstComPort = 1
Private Const LastComPort = 16
Public Function IsPortInList(lstComPortList As Object, ByVal iComPort As Integer) As Boolean
Dim idxComPort As Integer
On Error GoTo GetPortFromListError
IsPortInList = False
For idxComPort = 0 To lstComPortList.ListCount - 1
If (lstComPortList.ItemData(idxComPort) = iComPort) Then
IsPortInList = True
End If
Next
Exit Function
GetPortFromListError:
'MsgBox Err.Description, vbCritical, "IsPortInList ComPort Resource List Error"
End Function
Public Function GetPortListIndex(lstComPortList As Object, ByVal iComPort As Integer) As Integer
Dim idxComPort As Integer
On Error GoTo GetPortFromListError
GetPortListIndex = -1
For idxComPort = 0 To lstComPortList.ListCount - 1
If (lstComPortList.ItemData(idxComPort) = iComPort) Then
GetPortListIndex = idxComPort
End If
Next
Exit Function
GetPortFromListError:
'MsgBox Err.Description, vbCritical, "GetPortListIndex ComPort Resource List Error"
End Function
Public Function isComPortAvailable(ByVal iComPort As Integer) As Boolean
Dim hComPort As Long
Dim lpSecAttr As SECURITY_ATTRIBUTES
Dim lRetVal As Long
On Error GoTo isComPortAvailableError
hComPort = CreateFile("\\.\COM" & iComPort & "", 0, FILE_SHARE_READ + FILE_SHARE_WRITE, lpSecAttr, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)
If hComPort = INVALID_HANDLE_VALUE Then
isComPortAvailable = False
Else
isComPortAvailable = True
lRetVal = CloseHandle(hComPort)
End If
Exit Function
isComPortAvailableError:
MsgBox Err.Description, vbCritical, "is ComPort Available Test Error"
End Function
Public Sub CreateComPortResource(lstComPortList As Object)
Dim idxComPort As Integer
On Error GoTo CreateComPortResourceError
lstComPortList.Clear
For idxComPort = FirstComPort To LastComPort
If isComPortAvailable(idxComPort) Then
lstComPortList.AddItem "COM" & idxComPort
lstComPortList.ItemData(lstComPortList.NewIndex) = idxComPort
End If
Next
Exit Sub
CreateComPortResourceError:
MsgBox Err.Description, vbCritical, "CreateComPort Resource List Error"
End Sub
Public Function isAnyComPort() As Boolean
Dim idxComPort As Integer
Dim bHavePort As Boolean
On Error GoTo isAnyComPortError
bHavePort = False
isAnyComPort = False
For idxComPort = FirstComPort To LastComPort
If isComPortAvailable(idxComPort) Then
bHavePort = True
End If
Next
isAnyComPort = bHavePort
Exit Function
isAnyComPortError:
MsgBox Err.Description, vbCritical, "isAnyComPort Resource Error"
End Function
Public Function GetFirstComPort() As Integer
Dim idxComPort As Integer
On Error GoTo GetFirstComPortError
GetFirstComPort = 0
For idxComPort = FirstComPort To LastComPort
If isComPortAvailable(idxComPort) Then
GetFirstComPort = idxComPort
Exit Function
End If
Next
Exit Function
GetFirstComPortError:
MsgBox Err.Description, vbCritical, "GetFirstComPort Resource Error"
End Function
Public Function GetBaudRate(strSettings As String) As String
Dim lPos As Long
lPos = InStr(1, strSettings, ","),
If (lPos > 0) Then
GetBaudRate = Left(strSettings, lPos - 1)
Else
GetBaudRate = ""
End If
End Function
Public Function ToggleBaudRate(strSettings As String) As String
Dim lPos As Long
Dim strNewSettings As String
Dim strBaudRate As String
On Error GoTo ToggleBaudRateError
lPos = InStr(1, strSettings, ","),
If (lPos > 0) Then
strBaudRate = Left(strSettings, lPos - 1)
If (strBaudRate = "115200") Then
strBaudRate = "57600"
ElseIf (strBaudRate = "57600") Then
strBaudRate = "115200"
Else
strBaudRate = ""
End If
If (Len(strBaudRate) > 0) Then
ToggleBaudRate = strBaudRate & Mid(strSettings, lPos)
Else
ToggleBaudRate = strSettings
End If
Else
ToggleBaudRate = strSettings
End If
Exit Function
ToggleBaudRateError:
MsgBox Err.Description, vbCritical, "Toggle Baud Rate Error"
End Function