frmcardmk.frm

用MSCOMM控件作的刷卡程序

        GetData = ""
        NewCard = True
        GoTo H123
        Exit Sub
    End If
    Label4.Caption = "RF/64格式"
    Label4.BackColor = &HFF&
    RF32Type = 0
Else
    Label4.Caption = "RF/32格式"
    Label4.BackColor = &H800000
    RF32Type = 1
End If

H123:
Conv2Txt GetData, getText

For j = 0 To 6
    Text1(j).Text = ""
Next j

For j = 0 To Blocknum - 1
    Text1(j).Text = getText(j + 1)
Next j

If Trim(Text1(0).Text) <> mCardID Then
    NewCard = True
    KeyPressed = False
End If

    mCardID = Trim(Text1(0).Text)
    mArea = Mid(Trim(Text1(2).Text), 1, 4)
    mAmount = Mid(Trim(Text1(1).Text), 1, 4)

If Option2(0).Value = True And KeyPressed = False And NewCard Then
    Text2(0).Text = mCardID
    Text2(1).Text = mAmount
    Text2(2).Text = mArea
    NewCard = False
    
End If

End Sub

Private Function ReadCard(RF32 As Integer) As Variant
Dim Sbuf(5) As Byte
Dim Vsend As Variant
Dim Vread As Variant
Dim ReadRF As Variant
Dim Vgot As Variant
Dim ltime As Integer, i As Integer

ReadRF = ""

Sbuf(0) = 126
Sbuf(1) = 242
Sbuf(2) = RF32
Sbuf(3) = 0
Sbuf(4) = 242 + RF32
Sbuf(5) = 13
Vsend = Sbuf

'发送读命令
MSComm1.Output = Vsend

'读出数据
ltime = 0
Do While MSComm1.InBufferCount = 0
    'ltime = ltime + 1
    'If ltime > 30000 Then Exit Do
Loop

For i = 0 To 4
    Vgot = MSComm1.Input
    ReadRF = ReadRF & Vgot
    If InStrB(Vgot, ChrB(13)) Then Exit For
    ltime = 0
    Do While MSComm1.InBufferCount = 0
     '   ltime = ltime + 1
     '   If ltime > 30000 Then Exit Do
    Loop

Next

ReadCard = ReadRF

End Function

Private Sub WriteCard(ByVal Sectn As Integer, ByRef WrData As String)
Dim Sbuf() As Byte
Dim Rbuf As Variant
Dim Vsend As Variant
Dim nBufSiz As Integer
Dim i As Integer, n As Integer
Dim ltime As Integer

Dim mTString As String
Dim mWData(10) As Byte
Dim mWMode As Byte
Dim mDLen As Byte

mTString = WrData & mPassWord
Txt2Array mWData, mTString
If Len(mTString) = 16 Then
    mWMode = &H10 Or Sectn
    mDLen = 8
Else
    mWMode = Sectn
    mDLen = 4
End If

mWData(mDLen + 1) = mWData(mDLen + 1) Xor mWMode Xor 243 Xor mDLen

nBufSiz = 0
For i = 0 To 9
If mWData(i) = 126 Or mWData(i) = 13 Or mWData(i) = 92 Then nBufSiz = nBufSiz + 1
Next i

ReDim Sbuf(nBufSiz + mDLen + 6)

Sbuf(0) = 126
Sbuf(1) = 243
Sbuf(2) = mWMode
Sbuf(3) = mDLen

n = 4

For i = 0 To mDLen + 1

Select Case mWData(i)
Case 13
    Sbuf(n) = &H5C
    n = n + 1
    Sbuf(n) = &H45
    n = n + 1
Case 92
    Sbuf(n) = &H5C
    n = n + 1
    Sbuf(n) = &H2F
    n = n + 1

Case 126
    Sbuf(n) = &H5C
    n = n + 1
    Sbuf(n) = &H53
    n = n + 1

Case Else
    Sbuf(n) = mWData(i)
    n = n + 1
    
End Select

Next i

Sbuf(n) = 13

Vsend = Sbuf

MSComm1.Output = Vsend

ltime = 1
Do While MSComm1.InBufferCount = 0
'ltime = ltime + 1
'If ltime > 10000 Then GoTo ErrCard

Loop
'n = MSComm1.InBufferCount
'ReDim Rbuf(n)

ltime = 1

For i = 0 To 7
    Rbuf = MSComm1.Input
    If InStrB(Rbuf, ChrB(13)) Then Exit For
    ltime = 0
    Do While MSComm1.InBufferCount = 0
  '  ltime = ltime + 1
  '  If ltime > 10000 Then GoTo ErrCard
    Loop
    
Next

ErrCard:

End Sub

Private Sub Buzz(Beep As Integer)

Dim Sbuf(7) As Byte
Dim Vsend As Variant
Dim Vgot As Variant
Dim ltime As Integer, i As Integer

Sbuf(0) = 126
Sbuf(1) = 245
Sbuf(2) = 1
Sbuf(3) = 1
Sbuf(4) = 1
Sbuf(5) = 1
Sbuf(6) = 245
Sbuf(7) = 13
Vsend = Sbuf

MSComm1.Output = Vsend

ltime = 0
Do While MSComm1.InBufferCount = 0
ltime = ltime + 1
If ltime > 1000 Then Exit Do
Loop

For i = 0 To 4
    Vgot = MSComm1.Input
    If InStrB(Vgot, ChrB(13)) Then Exit For
Next i

End Sub

Private Sub Conv2Txt(ByVal ReadStr As Variant, ByRef RdString As Variant)
'ReadStr 为读卡得来的字符串
'RdString 为分解为最多七个区的字符串数组
Dim tmStr1 As String
Dim tmByte As Byte
Dim n As Integer, m As Integer, j As Integer
Dim i As Integer

On Error Resume Next
n = UBound(RdString)

For i = 1 To n
RdString(i) = ""
Next i

If ReadStr = "" Then Exit Sub
n = AscB(MidB(ReadStr, 4, 1)) \ 4
m = 0
For i = 1 To n
    For j = 1 To 4
        tmByte = AscB(MidB(ReadStr, 4 * i + j + m, 1))
        If tmByte = &H5C Then
            m = m + 1
            tmByte = AscB(MidB(ReadStr, 4 * i + j + m, 1))
            Select Case tmByte
            Case 47
                tmByte = &H5C
            Case 69
                tmByte = &HD
            Case 83
                tmByte = &H7E
            End Select
        End If
        
        tmStr1 = Hex(tmByte)
        If Len(tmStr1) = 1 Then tmStr1 = "0" & tmStr1
        RdString(i) = RdString(i) & tmStr1
    Next j
Next i
End Sub

Private Function Keyword(Cardnum As String) As String

Dim mPassWD As String
Dim mPwd As String
Dim mFlag1 As Integer
Dim mFlag2 As Integer
Dim mPass(4) As Byte
Dim n As Integer
Dim k As Integer

mPassWD = Trim(Cardnum)
'mPassWD = "FEDCBA01"
If mPassWD = "" Then Exit Function

For n = 0 To 3
    mPass(3 - n) = CByte("&H" & Mid(mPassWD, 2 * n + 1, 2))
Next n

For n = 0 To CardType + 1
    mFlag1 = (mPass(3) And &H80) \ 128
    For k = 0 To 3
        mFlag2 = (mPass(k) And &H80) \ 128
        mPass(k) = (mPass(k) And &H7F) * 2 + mFlag1
        mFlag1 = mFlag2
    Next k
Next n

mPass(0) = mPass(0) + CardType + 2

mPassWD = ""
For n = 0 To 3
    mPwd = Hex(mPass(n))
    If Len(mPwd) = 1 Then mPwd = "0" & mPwd
    mPassWD = mPwd & mPassWD
Next n

Keyword = mPassWD

End Function

Private Sub Txt2Array(Sdata As Variant, ByVal aText As String)

Dim tmText1 As String
Dim tmText3 As String
Dim sum1 As Integer
Dim sum2 As Byte
Dim i As Integer
Dim mTLen As Integer

tmText1 = Trim(aText)
mTLen = Len(tmText1) / 2

For i = 0 To mTLen - 1

    tmText3 = "&H" & Mid(tmText1, 2 * i + 1, 2)
         
    Sdata(i) = Val(tmText3)
    sum1 = sum1 + Sdata(i)
    
Next i

Do While sum1 > 255
sum1 = sum1 - 256
Loop

Sdata(mTLen) = sum1
For i = 0 To mTLen
sum2 = sum2 Xor Sdata(i)
Next i
Sdata(mTLen + 1) = sum2

End Sub

Private Function enKeyword(ByVal enKey As String) As String
Dim KyTime As String
Dim HourNum As Integer
Dim MinuteNum As Integer
Dim SecondNum As Single
Dim tmRND As Single
Dim tmKeyword As String
Dim tmKey As Long
Dim ekLen As Integer
Dim tmRNDPos As Integer
Dim i As Integer, j As Integer

KyTime = CStr(Time)

HourNum = Hour(KyTime)
MinuteNum = Minute(KyTime)
SecondNum = Second(KyTime)

tmRNDPos = 0
tmRND = Rnd(-CSng(SecondNum))
For i = 1 To HourNum + 1
    For j = 1 To MinuteNum + 1
    tmRND = Rnd(j)
    tmRNDPos = tmRNDPos + 1
    Next j
Next i

tmKeyword = ChrW((SecondNum) Xor AscW("飞")) & ChrW((tmRNDPos) Xor AscW("熊"))

ekLen = Len(enKey)

For i = 1 To ekLen
    tmKey = AscW(Mid(enKey, i, 1)) Xor Int(65536 * tmRND)
    If tmKey < 0 Then tmKey = tmKey + 65536
    tmKeyword = tmKeyword & ChrW(tmKey)
    tmRND = Rnd(i)
Next i

enKeyword = tmKeyword


End Function

Private Function deKeyword(ByVal deKey As String) As String


Dim tmKeyword As String
Dim tmRND As Single
Dim tmKey As Long
Dim ekLen As Integer
Dim tmRNDPos As Integer
Dim nSeed As Single
Dim i As Integer

ekLen = Len(deKey)
nSeed = -CSng(AscW(Mid(deKey, 1, 1)) Xor AscW("飞"))
tmRND = Rnd(nSeed)

tmRNDPos = CInt(AscW(Mid(deKey, 2, 1)) Xor AscW("熊"))
tmKeyword = ""
For i = 1 To tmRNDPos
tmRND = Rnd(i)

Next

For i = 3 To ekLen
    tmKey = AscW(Mid(deKey, i, 1)) Xor Int(65536 * tmRND)
    If tmKey < 0 Then tmKey = tmKey + 65536
    tmKeyword = tmKeyword & ChrW(tmKey)
    tmRND = Rnd(i)
Next i
deKeyword = tmKeyword

End Function

Private Function modiSKey(ByVal orSkey As String, ByVal oldData As Variant, ByVal newData As Variant) As String

Dim tmKeyword As String
Dim tmRND As Single
Dim tmKey As Long
Dim ekLen As Integer
Dim tmRNDPos As Integer
Dim nSeed As Single
Dim i As Integer

ekLen = Len(orSkey)
nSeed = -CSng(AscW(Mid(orSkey, 1, 1)) Xor AscW("飞"))
tmRND = Rnd(nSeed)

tmRNDPos = CInt(AscW(Mid(orSkey, 2, 1)) Xor AscW("熊"))
tmKeyword = ""
For i = 1 To tmRNDPos
tmRND = Rnd(i)

Next

For i = 3 To ekLen
    tmKey = AscW(Mid(orSkey, i, 1)) Xor Int(65536 * tmRND)
    If tmKey < 0 Then tmKey = tmKey + 65536
    tmKeyword = tmKeyword & ChrW(tmKey)
    tmRND = Rnd(i)
Next i
modiSKey = tmKeyword

End Function

Private Sub WriteMode()
Dim Sbuf() As Byte
Dim Rbuf As Variant
Dim Vsend As Variant
Dim nBufSiz As Integer
Dim i As Integer, n As Integer
Dim ltime As Integer

Dim mTString As String
Dim mWData(10) As Byte
Dim mWMode As Byte
Dim mDLen As Byte

mTString = mCardCon & mPassWord
Txt2Array mWData, mTString
mDLen = Len(mTString) / 2
If mDLen = 8 Then
    mWMode = &H10
Else
    mWMode = &H0
End If

mWData(mDLen + 1) = mWData(mDLen + 1) Xor mWMode Xor mDLen Xor 244

nBufSiz = 0
For i = 4 To mDLen + 1
If mWData(i) = 126 Or mWData(i) = 13 Or mWData(i) = 92 Then nBufSiz = nBufSiz + 1
Next i

ReDim Sbuf(nBufSiz + mDLen + 6)

Sbuf(0) = 126
Sbuf(1) = 244
Sbuf(2) = mWMode
Sbuf(3) = mDLen
For i = 0 To 3  '模式字
    Sbuf(4 + i) = mWData(i)
Next i

n = 8
For i = 4 To mDLen + nBufSiz + 1

Select Case mWData(i)
Case 13
    Sbuf(n) = &H5C
    n = n + 1
    Sbuf(n) = &H45
    n = n + 1
Case 92
    Sbuf(n) = &H5C
    n = n + 1
    Sbuf(n) = &H2F
    n = n + 1

Case 126
    Sbuf(n) = &H5C
    n = n + 1
    Sbuf(n) = &H53
    n = n + 1

Case Else
    Sbuf(n) = mWData(i)
    n = n + 1
    
End Select

Next i
Sbuf(n) = 13

Vsend = Sbuf

MSComm1.Output = Vsend

ltime = 1
Do While MSComm1.InBufferCount = 0
'ltime = ltime + 1
'If ltime > 50000 Then GoTo ErrCard

Loop
'n = MSComm1.InBufferCount
'ReDim Rbuf(n)

ltime = 1

For i = 0 To 7
    Rbuf = MSComm1.Input
    If InStrB(Rbuf, ChrB(13)) Then Exit For
    ltime = 0
    Do While MSComm1.InBufferCount = 0
  '  ltime = ltime + 1
  '  If ltime > 10000 Then GoTo ErrCard
    Loop
    
Next

ErrCard:



End Sub

Private Function ReadCd() As Boolean

Dim GetData As Variant
Dim getText(7) As String
Dim Blocknum As Integer


On Error Resume Next
GetData = ReadCard(1)
Blocknum = AscB(MidB(GetData, 4, 1)) \ 4
If Blocknum = 0 Then
    GetData = ReadCard(0)
    Blocknum = AscB(MidB(GetData, 4, 1)) \ 4
    If Blocknum = 0 Then
        GetData = ""
        GoTo RD001
        Exit Function
    End If
    Label4.Caption = "RF/64格式"
    Label4.BackColor = &HFF&
    RF32Type = 0
Else
    Label4.Caption = "RF/32格式"
    Label4.BackColor = &H800000
    RF32Type = 1
End If

RD001:
Conv2Txt GetData, getText

If getText(7) <> "" Then
    ReadCd = True
Else
    ReadCd = False
End If

End Function