misc.bas

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

Attribute VB_Name = "misc"
Option Explicit

Declare Sub Sleep Lib "kernel32" (ByVal dwSeconds As Long)
Declare Function GetTickCount Lib "kernel32" () As Long

Function HexToLong(ByVal sHex As String) As Long
Dim lValue As Long, i As Integer
Dim ch As String

    For i = 1 To Len(sHex)
        ch = UCase(Mid(sHex, i, 1))
        If ch >= "0" And ch <= "9" Then
            lValue = lValue * 16 + Asc(ch) - &H30
        ElseIf ch >= "A" And ch <= "F" Then
            lValue = lValue * 16 + Asc(ch) - &H41 + 10
        Else
            Exit For
        End If
    Next
    
    HexToLong = lValue
End Function

' Append aSourceBytes to aDestBytes
Sub ConcatBytes(ByRef aDestBytes As Variant, ByRef aSourceBytes As Variant, Optional lSourceOffset As Long = 0, Optional lLength As Long = -1)
Dim lUBound As Long, i As Long, iOffset As Long
Dim aTempBytes As Variant

    If lLength = -1 Then lLength = UBound(aSourceBytes) - lSourceOffset + 1
    ReDim aTempBytes(0 To lLength - 1) As Byte
    For i = 0 To lLength - 1
        aTempBytes(i) = aSourceBytes(i + lSourceOffset)
    Next

    If TypeName(aDestBytes) = "Empty" Then
        aDestBytes = aTempBytes
    Else
        iOffset = UBound(aDestBytes) + 1
        lUBound = UBound(aDestBytes) + lLength
        
        ReDim Preserve aDestBytes(0 To lUBound) As Byte
        For i = 0 To UBound(aTempBytes)
            aDestBytes(iOffset + i) = aTempBytes(i)
        Next
    End If
End Sub

'Append a single value to aDestBytes
Public Sub ConcatArray(ByRef aDestBytes As Variant, ByVal Value As Variant)
Dim lUBound As Long

    If TypeName(Value) = "Empty" Then Exit Sub
    If TypeName(aDestBytes) = "Empty" Then
        ReDim aDestBytes(0 To 0)
        aDestBytes(0) = Value
    Else
        lUBound = UBound(aDestBytes) + 1
        
        ReDim Preserve aDestBytes(0 To lUBound)
        aDestBytes(lUBound) = Value
    End If
End Sub

Public Function FormatHex(ByVal Value As Variant, Optional sPrefix As String = "", Optional ByVal iLen As Integer = 2) As String
Dim sResult As String

    FormatHex = sPrefix & Right(String(iLen, "0") & Hex(Value), iLen)
End Function

' Return the char position
' Return 0 if none is found
Public Function FindChar(ByVal sChar As String, ByVal sLine As String, Optional ByVal iOccurrence As Integer = 1) As Integer
Dim i As Integer, iCount As Integer, iPos As Integer

    For i = 1 To Len(sLine)
        If Mid(sLine, i, 1) = sChar Then iCount = iCount + 1
        If iCount >= iOccurrence Then
            iPos = i
            Exit For
        End If
    Next
    
    FindChar = iPos
End Function