base.bas

这是一个银行IC卡门禁系统软件

Attribute VB_Name = "base"
Option Explicit

Declare Function TMValidSession Lib "IBFS32.DLL" (ByVal session_handle As Long) As Integer
Declare Function TMExtendedStartSession Lib "IBFS32.DLL" (ByVal PortNum As Integer, ByVal PortType As Integer, ByVal Reserved As Any) As Long
Declare Function TMEndSession Lib "IBFS32.DLL" (ByVal session_handle As Long) As Integer

Declare Function TMFirstFile Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte, fentry As Byte) As Integer
Declare Function TMNextFile Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte, fentry As Byte) As Integer
Declare Function TMOpenFile Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte, fentry As Byte) As Integer
Declare Function TMCreateFile Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte, maxwrite As Integer, fentry As Byte) As Integer
Declare Function TMCloseFile Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte, ByVal file_handle As Integer) As Integer
Declare Function TMReadFile Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte, ByVal file_handle As Integer, read_buffer As Byte, ByVal max_read As Integer) As Integer
Declare Function TMWriteFile Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte, ByVal file_handle As Integer, write_buffer As Byte, ByVal num_write As Integer) As Integer
Declare Function TMDeleteFile Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte, fentry As Byte) As Integer
Declare Function TMFormat Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte) As Integer
Declare Function TMAttribute Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte, ByVal attrib As Integer, fentry As Byte) As Integer
Declare Function TMReNameFile Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte, ByVal file_handle As Integer, fentry As Byte) As Integer
Declare Function TMChangeDirectory Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte, ByVal operation As Integer, cd_buf As Byte) As Integer
Declare Function TMDirectoryMR Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte, ByVal operation As Integer, fentry As Byte) As Integer
Declare Function TMCreateProgramJob Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte) As Integer
Declare Function TMDoProgramJob Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte) As Integer
Declare Function TMWriteAddFile Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte, ByVal operation As Integer, ByVal offset As Integer, write_buffer As Byte, ByVal num_write As Integer) As Integer
Declare Function TMTerminateAddFile Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte, fentry As Byte) As Integer

Declare Function TMReadPacket Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte, ByVal StartPg As Integer, ReadBuf As Byte, ByVal MaxRead As Integer) As Integer
Declare Function TMWritePacket Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte, ByVal StartPg As Integer, ReadBuf As Byte, ByVal Writelen As Integer) As Integer
Declare Function TMExtendedReadPage Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte, ByVal StartPg As Integer, ReadBuf As Byte, ByVal MSpace As Integer) As Integer
Declare Function TMProgramByte Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte, ByVal WRByte As Integer, ByVal Addr As Integer, ByVal MSpace As Integer, Bits As Integer, ByVal Zeros As Integer) As Integer
Declare Function TMBlockIO Lib "IBFS32.DLL" (ByVal session_handle As Long, tran_buffer As Byte, ByVal num_tran As Integer) As Integer

Declare Function TMFirst Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte) As Integer
Declare Function TMNext Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte) As Integer
Declare Function TMAccess Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte) As Integer
Declare Function TMStrongAccess Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte) As Integer
Declare Function TMStrongAlarmAccess Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte) As Integer
Declare Function TMOverAccess Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte) As Integer
Declare Function TMRom Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte, ROM As Integer) As Integer
Declare Function TMFirstAlarm Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte) As Integer
Declare Function TMNextAlarm Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte) As Integer
Declare Function TMSkipFamily Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte) As Integer
Declare Function TMFamilySearchSetup Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte, ByVal family_type As Integer) As Integer
Declare Function TMAutoOverDrive Lib "IBFS32.DLL" (ByVal session_handle As Long, state_buffer As Byte, Mode As Integer) As Integer

Declare Function TMSetup Lib "IBFS32.DLL" (ByVal session_handle As Long) As Integer
Declare Function TMTouchByte Lib "IBFS32.DLL" (ByVal session_handle As Long, ByVal outbyte As Integer) As Integer
Declare Function TMTouchReset Lib "IBFS32.DLL" (ByVal session_handle As Long) As Integer
Declare Function TMTouchBit Lib "IBFS32.DLL" (ByVal session_handle As Long, ByVal outbit As Integer) As Integer
Declare Function TMProgramPulse Lib "IBFS32.DLL" (ByVal session_handle As Long) As Integer
Declare Function TMTClose Lib "IBFS32.DLL" (ByVal session_handle As Long) As Integer

Declare Function Get_Version Lib "IBFS32.DLL" (ByVal ID_buf$) As Integer
Declare Function TMGetTypeVersion Lib "IBFS32.DLL" (ByVal HSType As Integer, ByVal ID_buf$) As Integer

Public Function DateToBCD(ByVal vDate As Date) As String

    Dim strYear As String
    Dim strMonth As String
    Dim strDay As String
    Dim strHour As String
    Dim strMinute As String
    Dim strSecond As String
    Dim strWW As String
    
    strYear = Year(vDate)

    If Len(strYear) = 4 Then

        strYear = Right(strYear, 2)

    End If

    strMonth = Month(vDate)
    strDay = Day(vDate)
    strHour = Hour(vDate)
    strMinute = Minute(vDate)
    strSecond = Second(vDate)
    strWW = "00"
    
    If Len(strMonth) = 1 Then

        strMonth = "0" & strMonth

    End If

    If Len(strDay) = 1 Then

        strDay = "0" & strDay

    End If

    If Len(strHour) = 1 Then

        strHour = "0" & strHour

    End If

    If Len(strMinute) = 1 Then

        strMinute = "0" & strMinute

    End If
    
    If Len(strSecond) = 1 Then
       strSecond = "0" & strSecond
    End If
    
    If Len(strWW) = 1 Then
       strWW = "0" & strWW
    End If
    
    DateToBCD = strSecond & strMinute & strHour & strDay & strMonth & strWW & strYear

End Function

Public Function ShortDateToBCD(ByVal vDate As Date) As String

    Dim strHour As String
    Dim strMinute As String

    strHour = Hour(vDate)
    strMinute = Minute(vDate)

    If Len(strHour) = 1 Then

        strHour = "0" & strHour

    End If

    If Len(strMinute) = 1 Then

        strMinute = "0" & strMinute

    End If

    ShortDateToBCD = strHour & strMinute

End Function

Public Function BCDToDate(ByVal strBCD As String) As Date

    If Len(strBCD) <> 10 Then

        Err.Raise 60012, "BCDToDate", GetError(12)
        BCDToDate = 0
        Exit Function

    End If
    
    Dim i As Integer

    For i = 1 To 14

        If Val("&h" & Mid(strBCD, i, 1)) > 9 Then

            BCDToDate = 0
            Exit Function

        End If

    Next

    Dim strYear As String
    Dim strMonth As String
    Dim strDay As String
    Dim strHour As String
    Dim strMinute As String
    Dim strWW As String
    Dim strSecond As String
    
    strYear = Mid(strBCD, 13, 2)
    strWW = Mid(strBCD, 11, 2)
    strMonth = Mid(strBCD, 9, 2)
    strDay = Mid(strBCD, 7, 2)
    strHour = Mid(strBCD, 5, 2)
    strMinute = Mid(strBCD, 3, 1)
    strSecond = Mid(strBCD, 1, 2)
    
    Dim strtemp As String
    strtemp = "20" & strYear & "-" & strMonth & "-" & strDay & " " & _
       strHour & ":" & strMinute & ":" & strSecond

    If strtemp = "2000-00-00 00:00:00" Then

        BCDToDate = 0

    Else

        BCDToDate = CDate(strtemp)

    End If

End Function

Public Function BCDToShortDate(ByVal strBCD As String) As Date

    If Len(strBCD) <> 4 Then

        Err.Raise 60012, "BCDToDate", GetError(12)
        BCDToShortDate = 0
        Exit Function

    End If
    
    Dim i As Integer

    For i = 1 To 4

        If Val("&h" & Mid(strBCD, i, 1)) > 9 Then

            BCDToShortDate = 0
            Exit Function

        End If

    Next

    Dim strHour As String
    Dim strMinute As String

    strHour = Mid(strBCD, 1, 2)
    strMinute = Mid(strBCD, 3, 2)

    Dim strtemp As String
    strtemp = strHour & ":" & strMinute

    BCDToShortDate = CDate(strtemp)

End Function

Public Function CurToHexStr(ByVal vCurrency As Currency, ByVal length As Byte) As String

    Dim CurInt As Long
    Dim CurDec As Byte

    Dim CurHex As String
    Dim strHexCurDec As String

    CurInt = CLng(LTrim(Str(Int(vCurrency))))

    CurDec = CByte(Left(LTrim(Str(Int((vCurrency - Int(vCurrency)) * 100))), 2))

    strHexCurDec = Hex(CurDec)

    If Len(strHexCurDec) = 1 Then

        strHexCurDec = "0" & strHexCurDec

    End If

    If Len(strHexCurDec) = 0 Then

        strHexCurDec = "00" & strHexCurDec

    End If

    CurHex = Hex(CurInt) & strHexCurDec

    Dim i As Integer

    If Len(CurHex) < length * 2 Then

        For i = 1 To length * 2 - Len(CurHex)

            CurHex = "0" & CurHex

        Next

    End If

    CurToHexStr = CurHex

End Function

Public Function HexStrtoCur(ByVal strCur As String) As Currency

    Dim CurDec As Byte
    Dim CurInt As Long

    CurDec = CByte("&h" & Right(strCur, 2))

    CurInt = CLng("&h" & Mid(strCur, 1, Len(strCur) - 2))

    HexStrtoCur = CurInt + CurDec / 100#

End Function

Public Function DTA(ByVal dec As Long, ByVal length As Integer) As Byte()

    Dim strtmp() As Byte
    Dim strHex As String
    Dim lenstrHex As Integer
    Dim i As Integer
    Dim j As Integer

    ReDim strtmp(length)

    strHex = Hex(dec)
    lenstrHex = Len(strHex)

    If length * 2 < lenstrHex Then

        strHex = Right(strHex, length)

    ElseIf length * 2 > lenstrHex Then

        For i = lenstrHex To length * 2 - 1

            strHex = "0" & strHex

        Next

    End If

    For j = 0 To length - 1

        strtmp(j) = Val("&h" & Mid(strHex, j * 2 + 1, 2))

    Next

    DTA = strtmp

End Function

Public Function ATD(ByRef strHex() As Byte) As Long

    Dim dec As String
    Dim i As Integer

    dec = ""

    For i = 0 To UBound(strHex(), 1) - 1

        If strHex(i) = 0 Then

            dec = dec & "00"

        Else

            dec = dec & Hex(strHex(i))

        End If

    Next

    ATD = CLng("&h" & dec)

End Function

Public Function GetError(ByVal ErrorNum As Long) As String

    cnnClose

    Select Case ErrorNum
        
        Case -1
        
            GetError = "未找到TM卡"
            
        Case 0
            GetError = "未找到读写器。" '"通信端口可能被其它程序正在使用。"

        Case 1
            GetError = "卡损坏"

        Case 2
            GetError = "非本酒店卡"

        Case 3
            GetError = "旧卡"

        Case 4
            GetError = "空卡"

        Case 5
            GetError = "卡类错误,请换卡。"

        Case 10
            GetError = "属性未赋值"

        Case 11
            GetError = "函数调用超范围"

        Case 12
            GetError = "赋值越界,可能是空卡"

        Case 20
            GetError = "读写校验失败"
            
        Case 90
            GetError = "非Dallas 1990 型 TM 卡，请换卡。"
        
        Case 91
            GetError = "非Dallas 1991 型 TM 卡，请换卡。"
        
        Case 94
            GetError = "非Dallas 1994 型 TM 卡，请换卡。"
        
        Case 95
            GetError = "非Dallas 1995 型 TM 卡，请换卡。"

        Case Else
            GetError = "原因未明错误"

    End Select

End Function