mdlubr.bas

Test program for Hitachi Finger Vein

Attribute VB_Name = "mdlUBR"
Option Explicit

Public IsTimeOut As Boolean

Public bout() As Byte
Public bIn() As Byte

Public Reply(0 To 2048) As Byte
Private CheckSum As Variant

Private bData(0) As Byte
Private bTmp() As Byte
Private strData$
Private cntrLoop As Integer
Private cntrData As Integer
Private cntrSeqNo As Integer

Private dummy As Variant
Private bolContinue As Boolean

Private Sub ClearReceiveBuffer()
    Dim i As Integer
    
    For i = 0 To 2048
        Reply(i) = 0
    Next
End Sub
Public Function SendCommand(ByRef objCom As MSComm, ByRef objTimer As Timer, ByRef byteCmd() As Byte, ByVal intLen As Integer, ByVal intPartition As Integer, ByVal intSeqNo As Integer) As Long
    Dim i As Integer
    Dim intCheck As Long
    Dim intPartLen As Long
    Dim intDataLen As Long
    Dim intRetry As Integer
    Dim intRet As Integer
    Dim tmpLen(0 To 3) As Integer
    Dim tmpBuf(2068) As Byte
    Dim tmpOut(0) As Byte
    Dim strDataLen As String
    
    SendCommand = 0
    
    'Clearing Reply
    Call ClearReceiveBuffer
    
    If ((intLen Mod 8) = 0) Then
        intPartLen = 0
    Else
        intPartLen = 8 - (intLen Mod 8)
    End If
    
    intDataLen = intLen + intPartLen
    
    Call ClearCommBuffer(objCom)
    
    intRetry = 0
    intRet = 2
    
    Do
        intRetry = intRetry + 1
        Call Send_ENQ(objCom)
        intRet = Wait4Reply(objCom, objTimer, UBR_ACK, 1000)
    Loop While ((intRet = 2) And (intRetry <= 3))
    
    If intRet <> 1 Then
        If intRet = 0 Then
            Call Send_EOT(objCom)
        End If
        SendCommand = 0
        GoTo Exit_Function
    
    Else
    
        strDataLen = Right$("00000000" & Hex(intDataLen), 8)
        
        tmpLen(0) = "&H" & Mid$(strDataLen, 7, 2)
        tmpLen(1) = "&H" & Mid$(strDataLen, 5, 2)
        tmpLen(2) = "&H" & Mid$(strDataLen, 3, 2)
        tmpLen(3) = "&H" & Mid$(strDataLen, 1, 2)
        
        strDataLen = Right$("0000" & Hex(intSeqNo), 4)
        
        tmpBuf(0) = UBR_STX
        tmpBuf(1) = &H63
        tmpBuf(2) = CByte(intPartition)
        tmpBuf(3) = "&H" & Mid$(strDataLen, 3, 2)
        tmpBuf(4) = "&H" & Mid$(strDataLen, 1, 2)
        
        tmpBuf(5) = tmpLen(0)
        tmpBuf(6) = tmpLen(1)
        tmpBuf(7) = tmpLen(2)
        tmpBuf(8) = tmpLen(3)
        
        For i = 0 To intLen - 1
            tmpBuf(i + 9) = byteCmd(i)
        Next
        
        tmpBuf(9 + intDataLen) = UBR_ETX
        
        intCheck = 0
        For i = 1 To intDataLen + 9
            intCheck = intCheck + tmpBuf(i)
        Next
        
        tmpBuf(10 + intDataLen) = CByte(intCheck And &H7F)
        
        Call ClearCommBuffer(objCom)
        
        If OnDebugMode Then
            Debug.Print "intCheck=" & intCheck & "/" & Hex(intCheck)
            Debug.Print "Sending command ..."
        End If
        
        For i = 0 To intDataLen + 10
            tmpOut(0) = tmpBuf(i)
            objCom.Output = tmpOut
            'Debug.Print Right$("00" & Hex(tmpBuf(i)), 2)
        Next
        
        intRetry = 0
        intRet = 2
        
        Do
            intRetry = intRetry + 1
            intRet = Wait4Reply(objCom, objTimer, UBR_ACK, 500)
            If intRet = 2 Then
                Call ClearCommBuffer(objCom)
                For i = 0 To intDataLen + 10
                    tmpOut(0) = tmpBuf(i)
                    objCom.Output = tmpOut
                Next
            End If
        Loop While ((intRet = 2) And (intRetry <= 3))
        
        Call Send_EOT(objCom)
        
        If intRet <> 1 Or intRetry >= 3 Then
            SendCommand = 0
            GoTo Exit_Function
        Else
            If intPartition = 0 Then
                intRet = Wait4Reply(objCom, objTimer, UBR_ENQ, 3000)
                
                If OnDebugMode Then
                    Debug.Print "intRet=" & intRet
                End If
                
                If intRet = 0 Then
                    SendCommand = 0
                Else
                    Call Send_ACK(objCom)
                    
                    'Debug.Print "Receiving ..."
                    
                    bolContinue = True
                    intRetry = 0
                    intDataLen = 0
                    intPartLen = 0
                    
                    Do
                        IsTimeOut = False
                        objTimer.Interval = 3500
                        objTimer.Enabled = False
                        objTimer.Enabled = True
                        
                        Do
                            DoEvents
                            bTmp = objCom.Input
                            For i = LBound(bTmp) To UBound(bTmp)
                                If OnDebugMode Then
                                    Debug.Print Format(intDataLen, "000") & ":" & Right$("00" & Hex(bTmp(i)), 2)
                                End If
                                    
                                If ((intDataLen = 0) And (bTmp(i) = UBR_STX)) Then
                                    intDataLen = 0
                                    Call ClearReceiveBuffer
                                ElseIf (bTmp(i) = UBR_ETX) Then
                                    If intDataLen > 8 Then
                                        intPartLen = Reply(4) + (Reply(5) * 255) + (Reply(6) * 255 * 255) + (Reply(7) * 255 * 255 * 255)
                                        If (intPartLen + 8) <= intDataLen Then
                                            bolContinue = False
                                        Else
                                            Reply(intDataLen) = bTmp(i)
                                            intDataLen = intDataLen + 1
                                        End If
                                    Else
                                        Reply(intDataLen) = bTmp(i)
                                        intDataLen = intDataLen + 1
                                    End If
                                Else
                                    If OnDebugMode Then
                                        Debug.Print Format(intDataLen, "000") & ":" & Right$("00" & Hex(bTmp(i)), 2)
                                    End If
                                    
                                    Reply(intDataLen) = bTmp(i)
                                    intDataLen = intDataLen + 1
                                End If
                            Next
                            If IsTimeOut Or Not bolContinue Then Exit Do
                        Loop
                        
                        objTimer.Enabled = False
                        
                        intRetry = intRetry + 1
                        
                    Loop While (bolContinue And (intRetry < 3))
                    
                    'If Not bolContinue Then
                    '    Debug.Print "Got it"
                    'End If
                    
                    SendCommand = intDataLen
                    
                    Call Send_ACK(objCom)
                    
                    intRet = Wait4Reply(objCom, objTimer, UBR_EOT, 500)
                    If intRet = 0 Then
                        SendCommand = 0
                        GoTo Exit_Function
                    End If
                
                End If
                
            Else
                SendCommand = intLen
            End If
        End If
    End If
    
Exit_Function:
    Exit Function
    
End Function

Public Function Wait4Reply(ByRef objCom As MSComm, ByRef objTimer As Timer, ByVal bchar As Byte, ByVal nTimeOut As Long) As Integer
    Dim nRet As Boolean
    
    If objCom.PortOpen Then
        Wait4Reply = 2
        
        nRet = False
        IsTimeOut = False
        objTimer.Interval = nTimeOut
        objTimer.Enabled = False
        objTimer.Enabled = True
        cntrData = 0
        strData$ = ""
        
        Do
            DoEvents
            bTmp = objCom.Input
            For cntrLoop = LBound(bTmp) To UBound(bTmp)
                If bTmp(cntrLoop) = bchar Then
                    Wait4Reply = 1
                    nRet = True
                End If
                Reply(cntrData) = bTmp(cntrLoop)
                'Debug.Print Right$("00" & Hex(Reply(cntrData)), 2)
                'strData$ = strData$ & Right$("00" & Hex(Reply(cntrData)), 2)
                cntrData = cntrData + 1
            Next
            If IsTimeOut Or Wait4Reply = 1 Then Exit Do
        Loop
        
        If IsTimeOut And Not nRet Then
            Wait4Reply = 0
        End If
    Else
        Wait4Reply = 0
    End If
    
    objTimer.Enabled = False
End Function

Public Sub ClearCommBuffer(ByRef objCom As MSComm)
    objCom.OutBufferCount = 0
    objCom.InBufferCount = 0
    objCom.InputLen = 1
End Sub

Public Function Hex2Bin(ByVal bchar As Byte) As String
    Dim i As Integer
    Dim sTmp As String
    Dim sBin As String
    Dim sResult As String
    
    sTmp = Right$("00" & Hex(bchar), 2)
    
    sResult = ""
    
    For i = 1 To 2
        Select Case Mid$(sTmp, i, 1)
            Case "F": sBin = "1111"
            Case "E": sBin = "1110"
            Case "D": sBin = "1101"
            Case "C": sBin = "1100"
            Case "B": sBin = "1011"
            Case "A": sBin = "1010"
            Case "9": sBin = "1001"
            Case "8": sBin = "1000"
            Case "7": sBin = "0111"
            Case "6": sBin = "0110"
            Case "5": sBin = "0101"
            Case "4": sBin = "0100"
            Case "3": sBin = "0011"
            Case "2": sBin = "0010"
            Case "1": sBin = "0001"
            Case Else: sBin = "0000"
        End Select
        
        sResult = sResult & sBin
    Next
            
    Hex2Bin = sResult
End Function

Public Function Bin2Hex(ByVal sBin As String) As Byte
    Dim i As Integer
    Dim sTmp As String
    Dim sHex As String
    Dim sResult As String
    Dim bTmp As Byte
    
    sTmp = Right$(String$(8, "0") & sBin, 8)
    
    sResult = ""
    
    For i = 1 To 8 Step 4
        Select Case Mid$(sTmp, i, 4)
            Case "1111": sHex = "F"
            Case "1110": sHex = "E"
            Case "1101": sHex = "D"
            Case "1100": sHex = "C"
            Case "1011": sHex = "B"
            Case "1010": sHex = "A"
            Case "1001": sHex = "9"
            Case "1000": sHex = "8"
            Case "0111": sHex = "7"
            Case "0110": sHex = "6"
            Case "0101": sHex = "5"
            Case "0100": sHex = "4"
            Case "0011": sHex = "3"
            Case "0010": sHex = "2"
            Case "0001": sHex = "1"
            Case Else: sHex = "0"
        End Select
        
        sResult = sResult & sHex
    Next
    
    bTmp = "&H" & sResult
    Bin2Hex = bTmp
End Function

Public Function bitRShift(ByVal bchar As Byte, ByVal intShift As Integer) As Byte
    Dim i As Integer
    Dim sTmp As String
    
    sTmp = Right$(String(intShift, "0") & Hex2Bin(bchar), 8)
    sTmp = Right$(String$(8, "0") & Trim$(sTmp), 8)
    
    bitRShift = Bin2Hex(sTmp)
End Function

Public Function bitLShift(ByVal bchar As Byte, ByVal intShift As Integer) As Byte
    Dim i As Integer
    Dim sTmp As String
    
    sTmp = Right$(Hex2Bin(bchar) & String(intShift, "0"), 8)
    sTmp = Right$(String$(8, "0") & Trim$(sTmp), 8)
    
    bitLShift = Bin2Hex(sTmp)
End Function

Public Function SendByte(ByRef objCom As MSComm, ByVal bchar As Byte) As Boolean
    SendByte = False
    
    If objCom.PortOpen Then
        SendByte = True
        
        objCom.OutBufferCount = 0
        objCom.InBufferCount = 0
        objCom.InputLen = 1
        
        bData(0) = bchar
        objCom.Output = bData
    End If
End Function

Public Sub Send_ENQ(ByRef objCom As MSComm)
    Call SendByte(objCom, UBR_ENQ)
End Sub

Public Sub Send_EOT(ByRef objCom As MSComm)
    Call SendByte(objCom, UBR_EOT)
End Sub

Public Sub Send_ACK(ByRef objCom As MSComm)
    Call SendByte(objCom, UBR_ACK)
End Sub

Public Sub Send_NAK(ByRef objCom As MSComm)
    Call SendByte(objCom, UBR_NAK)
End Sub