clscomm.cls

一个VB实现串口通讯的经典示例.非常简明, 使用, 本人大部分通讯程序与之类同

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsComm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private m_ResultBytes As Variant, m_ResultHexStr As Variant
Private m_lStartAddress As Long ' for RDEP command
Private m_oComm As MSComm, m_bConnected As Boolean
Private m_sSystem As String ' FP or PP
Private m_iPort As Integer, m_lBaud As Long
Private m_oListCmd As ListBox, m_oListMsg As ListBox
Private m_bExecutingMacro As Boolean
Private m_oIntelHex As New clsIntelHex
Private m_bCompareResult As Boolean, m_iLastBuzzerID As Integer

Public Property Let Port(Value As Integer)
    m_iPort = Value
End Property

Public Property Get Port() As Integer
    Port = m_iPort
End Property

Public Property Let Baud(Value As Long)
    m_lBaud = Value
End Property

Public Property Get Baud() As Long
    Baud = m_lBaud
End Property

Public Property Get StartAddress() As Long
    StartAddress = m_lStartAddress
End Property

Public Property Get EndAddress() As Long
Dim lAddress As Long

    If TypeName(m_ResultBytes) <> "Empty" Then
        lAddress = m_lStartAddress + UBound(m_ResultBytes)
    End If
    EndAddress = lAddress
End Property

Public Property Get ByteCount() As Long
Dim lCount As Long

    If TypeName(m_ResultBytes) <> "Empty" Then
        lCount = UBound(m_ResultBytes) + 1
    End If
    
    ByteCount = lCount
End Property

Public Property Get ResultHexStr() As String
    ResultHexStr = m_ResultHexStr
End Property

Public Property Get ResultBytes() As Variant
    ResultBytes = m_ResultBytes
End Property

Public Property Get CompareResult() As Boolean
    CompareResult = m_bCompareResult
End Property

Public Sub AssignComm(ByRef oComm As MSComm, Optional ByRef oListCmd As ListBox = Null, Optional ByRef oListMsg As ListBox = Null)
    Set m_oComm = oComm
    Set m_oListCmd = oListCmd
    Set m_oListMsg = oListMsg
End Sub

Private Sub Class_Initialize()
    m_iPort = 1
    m_lBaud = 9600
End Sub

Public Function Execute(ByVal sCommand As String) As Boolean
Dim aParams As Variant, iPort As Integer, lBaud As Long
Dim bResult As Boolean, sFile As String

    aParams = Split(Trim(sCommand))
    
    bResult = True
    
    Select Case LCase(aParams(0))
    Case "connect"
        OpenComm
        Connect aParams(1)
    Case "rdep"
        ReadEEprom Mid(sCommand, 6)
    Case "wrep"
        WriteEEprom Mid(sCommand, 6)
    Case "port"
        iPort = CInt(Mid(sCommand, 6))
        If iPort >= 1 And iPort <= 4 Then
            m_iPort = iPort
            DisplayMsg "Change to port " & m_iPort
        Else
            DisplayMsg "Cannot change to port " & iPort
        End If
    Case "baud"
        lBaud = CLng(Mid(sCommand, 6))
        Select Case lBaud
        Case 9600, 19200, 57600, 115200
            m_lBaud = lBaud
            DisplayMsg "Change to buad " & m_lBaud
        Case Else
            DisplayMsg "Cannot change to baud " & lBaud
        End Select
    Case "import"
        sFile = Trim(Mid(sCommand, 8))
        If m_oIntelHex.ReadFile(sFile) Then
            DisplayMsg "Imported " & m_oIntelHex.PathName & " successfully (0x" & Hex(m_oIntelHex.StartAddress) & " - 0x" & Hex(m_oIntelHex.EndAddress) & ")"
        Else
            DisplayMsg "Import " & sFile & " failed"
        End If
    Case "compare"
        CompareBytes Mid(sCommand, 9)
    Case "close"
        CloseComm
        DisplayMsg "Com port " & m_iPort & " closed"
    Case "export"
        ExportToHex Mid(sCommand, 8)
    Case "@"
        DoMacro Mid(sCommand, 3)
    Case "version"
        CheckVersion
    Case "reset"
        ResetByWatchdog
    Case "buzzer"
        Buzzer Mid(sCommand, 8)
    Case "sendhex"
        SendHexCommand Mid(sCommand, 9)
    Case "clearreg"
        ClearRegistration
    Case "tbr6"
        EnterTBR 6
    Case "tbr10"
        EnterTBR 10
    Case Else
        bResult = False
        DisplayMsg "Invalid command: " & sCommand
    End Select

    Execute = bResult
End Function

' aData can be either Byte() or Integer()
Public Sub DisplayBytes(ByRef aData As Variant, Optional ByVal sPrefix As String = "", Optional ByVal iStart As Integer = 0, Optional ByVal iEnd As Integer = -1)
Dim sLine As String, i As Integer, iUpperBound As Integer

    If m_oListCmd Is Nothing Then Exit Sub
    If TypeName(aData) = "Empty" Then Exit Sub
    
    If sPrefix <> "" Then sLine = sPrefix & " "
    
    If iEnd = -1 Then
        iEnd = UBound(aData)
    Else
        If iEnd > UBound(aData) Then iEnd = UBound(aData)
    End If
    For i = iStart To iEnd
        sLine = sLine & Right("0" & Hex(aData(i)), 2) & " "
    Next
    sLine = Format(Now, "hh:mm:ss ") & Trim(sLine)
    
    With m_oListCmd
        .AddItem sLine, m_oListCmd.ListCount
        .ListIndex = m_oListCmd.ListCount - 1
        If .ListCount > 500 Then .RemoveItem 0
    End With

    oLog.WriteLine sLine
End Sub

Public Sub DisplayMsg(ByVal sMsg As String)
Dim sLine As String

    If m_oListMsg Is Nothing Then Exit Sub
    sLine = Format(Now, "hh:mm:ss ") & Trim(sMsg)
    
    With m_oListMsg
        .AddItem sLine, m_oListMsg.ListCount
        .ListIndex = m_oListMsg.ListCount - 1
        If .ListCount > 500 Then .RemoveItem 0
    End With
    
    oLog.WriteLine sLine
End Sub

Public Sub OpenComm()
Dim sSettings As String

    CloseComm
    
    sSettings = CStr(m_lBaud) & ",N,8,1"
    With m_oComm
        .CommPort = m_iPort
        .Settings = sSettings
        .Handshaking = comNone
        .InBufferCount = 0
        .InputLen = 0
        .InputMode = comInputModeBinary
        
        .PortOpen = True
    End With
End Sub

Public Sub CloseComm()
    With m_oComm
        If .PortOpen Then .PortOpen = False
    End With
End Sub

Private Sub AppendBytes(ByRef aBytes As Variant)
Dim i As Integer, iSize As Integer, iOffset  As Integer

    iSize = UBound(aBytes) + 1
    If TypeName(m_ResultBytes) <> "Empty" Then
        iOffset = UBound(m_ResultBytes) + 1
        ReDim Preserve m_ResultBytes(0 To iOffset + iSize - 1) As Byte
    Else
        iOffset = 0
        ReDim m_ResultBytes(0 To iOffset + iSize - 1) As Byte
    End If
    
    For i = 0 To UBound(aBytes)
        m_ResultBytes(iOffset + i) = aBytes(i)
    Next
End Sub

Public Function ReadBytes(ByVal iTotalCount, Optional nTermByte As Integer = -1, Optional lfTimeout As Double = 2) As Boolean
Dim bTimeOut As Boolean, iLen As Integer, i As Integer, lTimeOut As Long
Dim lLastReceivedChar As Long, bResult As Boolean
Dim aInput() As Byte, byteTermByte As Byte

    m_ResultBytes = Empty
    m_ResultHexStr = ""
    lTimeOut = lfTimeout * 1000 ' timeout in ms
    
    If nTermByte <> -1 Then byteTermByte = CByte(nTermByte)

    lLastReceivedChar = GetTickCount
    With m_oComm
        Do While .OutBufferCount > 0
            DoEvents
            If GetTickCount - lLastReceivedChar > lTimeOut Then
                bTimeOut = True
                Exit Do
            End If
        Loop
        
        ' start reading chars unti iTotalCount bytes received
        Do While Not bTimeOut
            If .InBufferCount > 0 Then
                aInput = .Input
                AppendBytes aInput
                lLastReceivedChar = GetTickCount
'Debug.Print "Input size: " & UBound(aInput) - LBound(aInput) + 1
                If UBound(m_ResultBytes) = iTotalCount - 1 Then
                    bResult = True
                    Exit Do
                End If
                
                ' check if termination byte is specified
                If nTermByte <> -1 Then
                    For i = 0 To UBound(m_ResultBytes)
                        If m_ResultBytes(i) = byteTermByte Then
                            bResult = True
                            Exit Do
                        End If
                    Next
                End If
            End If
            
            DoEvents
            If GetTickCount - lLastReceivedChar > lTimeOut Then
                bTimeOut = True
                Exit Do
            End If
        Loop
    End With
    
    If TypeName(m_ResultBytes) <> "Empty" Then
        For i = 0 To UBound(m_ResultBytes)
            m_ResultHexStr = m_ResultHexStr & " " & Right("0" & Hex(m_ResultBytes(i)), 2)
        Next
        m_ResultHexStr = Trim(m_ResultHexStr)
    End If
    
    DisplayBytes m_ResultBytes, "Rx"
    
    ReadBytes = bResult
End Function

Public Sub SendText(ByVal sData As String)
Dim aData As Variant, i As Integer, iLen As Integer

    If Not m_oComm.PortOpen Then
        ' com port not opened
        MsgBox "Com port not opened !", vbOKOnly, "Error"
        Exit Sub
    End If
    
    iLen = Len(sData)
    ReDim aData(0 To iLen - 1) As Integer
    For i = 0 To iLen - 1
        aData(i) = Asc(Mid(sData, i + 1, 1))
    Next
        
    DisplayBytes aData, "Tx"
    m_oComm.Output = sData
    
'    Do While m_oComm.OutBufferCount > 0
'        DoEvents
'    Loop

End Sub

' aData is integer array
Public Sub SendBytes(ByRef aData As Variant)
    m_oComm.Output = aData
    DisplayBytes aData, "Tx"
End Sub

' Return the byte array of the hex str
Public Function SendHex(ByVal sHex As String) As Variant
Dim aSegments As Variant, sData As String, i As Integer
Dim aData As Variant

    If Not m_oComm.PortOpen Then
        ' com port not opened
        MsgBox "Com port not opened !", vbOKOnly, "Error"
        Exit Function
    End If
    
    sHex = Trim(sHex)
    aSegments = Split(sHex)
    ReDim aData(0 To UBound(aSegments)) As Byte
    For i = 0 To UBound(aSegments)
        aData(i) = HexToLong(aSegments(i))
        sData = sData & Chr(aData(i))
    Next
    
    DisplayBytes aData, "Tx"
    m_oComm.Output = aData

    SendHex = aData
End Function

Public Function Connect(ByVal sSystem As String, Optional bInteractive As Boolean = True) As Boolean
Dim sCmd As String

    If Not m_oComm.PortOpen Then
        ' com port not opened
        If bInteractive Then MsgBox "Com port not opened !", vbOKOnly, "Error"
        Exit Function