misc.bas

应用串口通讯, 获取产品信息, 并与SAMPLE信息比较, 自动判断产品是否合格

Attribute VB_Name = "misc"
Option Explicit

Public Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMillSeconds As Long)

Public oComm As New clsComm, _
    oIntelHex As New clsIntelHex, _
    oLog As New clsLog

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

Function ReadParam(ByVal sCfgPath As String, ByVal sVarName As String) As Variant
Dim Result As Variant, sLine As String, sPart1 As String, sPart2 As String
Dim iFH As Integer, iEqualPos As Integer, ch As String

    sVarName = LCase(sVarName)
    iFH = FreeFile
    Open sCfgPath For Input As #iFH
    Do While Not EOF(iFH)
        Input #iFH, sLine
        ch = Left(sLine, 1)
        If ch = "" Or ch = "'" Or ch = "#" Or ch = ";" Then
            ' skip
        Else
            iEqualPos = FindChar("=", sLine)
            If iEqualPos > 0 Then
                sPart1 = LCase(Trim(Left(sLine, iEqualPos - 1)))
                If sPart1 = sVarName Then
                    Result = Trim(Mid(sLine, iEqualPos + 1))
                    Exit Do
                End If
            End If
        End If
    Loop
    Close #iFH
    iFH = 0

ReadParam_Error:
    On Error GoTo 0
    If iFH > 0 Then Close #iFH

    ReadParam = Result
End Function

Function PadL(ByVal Str As String, ByVal Length As Integer, Optional ByVal PadChar As String = " ", Optional ByVal Truncate As Boolean = False)
Dim sResult As String

    sResult = Right(String(Length, PadChar) & Str, Length)
    If Truncate Then sResult = Left(sResult, Length)
    PadL = sResult
End Function

Function PadR(ByVal Str As String, ByVal Length As Integer, Optional ByVal PadChar As String = " ", Optional ByVal Truncate As Boolean = False)
Dim sResult As String

    sResult = Left(Str & String(Length, PadChar), Length)
    If Truncate Then sResult = Left(sResult, Length)
    PadR = sResult
End Function

' Return the req'd substr segment
' The first segment : iPart=1
Function ExtractSubStr(ByVal sLine As String, ByVal iPart As Integer, Optional sSeparatorChar As String = " ")
Dim iPtr As Integer, sResult As String, bStartCopying As Boolean
Dim iCurrentPart As Integer, ch As String
    
    iCurrentPart = 1
    For iPtr = 1 To Len(sLine)
        ch = Mid(sLine, iPtr, 1)
        If ch = sSeparatorChar Then
            iCurrentPart = iCurrentPart + 1
        Else
            If iCurrentPart = iPart Then
                ' need to copy
                bStartCopying = True
            Else
                ' no need to copy
                If bStartCopying Then Exit For  ' copy already finished
                bStartCopying = False
            End If
            If bStartCopying Then sResult = sResult & ch
        End If
    Next
    
    ExtractSubStr = sResult
End Function