frmsetm1.frm

一个完整的非接触IC卡会员管理系统

        If Len(str) <= 6 Then
            Do While Not Len(str) = 6
                str = "0" + str
            Loop
        End If

        databuff32(2) = "&H" + Mid(str, 1, 2)
        databuff32(1) = "&H" + Mid(str, 3, 2)
        databuff32(0) = "&H" + Mid(str, 5, 2)
        
        
        If Option1.value = True Then
            databuff32(3) = &H4 '卡类
        Else
            databuff32(3) = &H2 '卡类
        End If
        databuff32(4) = &H1
        For i = 0 To 15
            databuff32(15) = databuff32(15) Xor databuff32(i)
        Next
        '写发行区信息
        bOperResult = MIFARE_WriteDataBlock(8, databuff32(0))
        If bOperResult <> 0 Then GoTo Err1:
        
        '初始化块值9 10
        For i = 0 To 3
            stValue(i) = &H0
        Next
        bOperResult = MIFARE_WriteValueBlock(9, stValue(0))
        If bOperResult <> 0 Then GoTo Err1:
        
        bOperResult = MIFARE_WriteValueBlock(10, stValue(0))
        If bOperResult <> 0 Then GoTo Err1:
        
        '18778e69  改密码和控制字
        For i = 0 To 5
            databuff32(i) = pbKeyA(i)
        Next
        
        databuff32(6) = &H18
        databuff32(7) = &H77
        databuff32(8) = &H8E
        databuff32(9) = &H69
            
        For i = 0 To 5
            databuff32(i + 10) = pbKeyB(i)
        Next
    
        bOperResult = MIFARE_WriteDataBlock(11, databuff32(0))
        If bOperResult <> 7 Then GoTo Err1:
    
    
        pscard.Open "select * from Full_UserDict", maSys_db, 3, 3
        pscard.AddNew
        pscard.Fields("userid") = Trim(txtCardNo)
        pscard.Fields("username") = Trim(txtName.Text)
        pscard.Fields("m1cardid") = "NULL"
        pscard.Fields("m1cardstate") = "启用"
        pscard.Fields("dept_name") = Combo1.Text
        pscard.Fields("settime") = Format(Now, "yyyy-mm-dd hh:mm:ss")
        pscard.Update
        pscard.Close
        MsgBox "发卡成功!", vbInformation + vbOKOnly, "提示"
        pssql = "select * from Full_UserDict order by userid"
        listrecord
        blOperResult = BuzzerSound(2)
    End If
Else
    MsgBox "输入不能为空，请输入...", vbInformation + vbOKOnly, "提示"
    txtCardNo.SetFocus
End If

GoTo Err1:
Exit Sub

err:
MsgBox "数据库错误！", vbInformation + vbOKOnly, "提示"
Exit Sub

Err1:
blOperResult = Disconnection()
End Sub

Private Sub cmdDel_Click()
If txtCardNo.Text = "" Then MsgBox "卡号不能为空！", vbInformation + vbOKOnly, "提示": Exit Sub
If MsgBox("确实要删除该卡和记录信息吗?", vbCritical + vbYesNo, "<提示信息>") = vbYes Then
    If Command2.Enabled = True Then
        blOperResult = ConnectionUSBDevice()
        If (blOperResult) Then
            
        Else
            GoTo Err1:
        End If
        DoEvents
        
        '先判断密码卡有决有装载过
        For i = 0 To 7
            KeyAP(i) = &H11
            KeyBP(i) = &H11
            KeyABP = True
        Next
        ''
        bOperResult = MIFARE_SelectCard(SerialNum(0))
        If bOperResult <> 0 Then
             GoTo Err1:
        End If
        CardId = Right("00" + hex(SerialNum(0)), 2) + Right("00" + hex(SerialNum(1)), 2) + Right("00" + hex(SerialNum(2)), 2) + Right("00" + hex(SerialNum(3)), 2)
        txtCardID = CardId
        
        For i = 0 To 3
            pbKeyID(i) = SerialNum(i)
            pbKeyID(i + 4) = SerialNum(i)
        Next
        '-----------------------------------------计算KEYA KEYB
        st = ic_encrypt(KeyAP(0), pbKeyID(0), 8, pbExdest(0)) 'KEYA
        If st <> 0 Then GoTo Err1:
        For i = 0 To 5
            pbKeyA(i) = pbExdest(i)
        Next
        
        st = ic_encrypt(KeyBP(0), pbKeyID(0), 8, pbExdest(0)) 'KEYB
        If st <> 0 Then GoTo Err1:
        For i = 0 To 5
            pbKeyB(i) = pbExdest(i)
        Next
        '检验卡是否是新卡，如果不是，从数据库查询卡的信息
        bOperResult = MIFARE_LoginSector(2, 1, pbKeyB(0))
        If bOperResult <> 0 Then GoTo Err1:
        
        '18778e69  改密码和控制字
        For i = 0 To 15
            databuff32(i) = &HFF
        Next
        databuff32(6) = &HFF
        databuff32(7) = &H7
        databuff32(8) = &H80
        databuff32(9) = &H69
        bOperResult = MIFARE_WriteDataBlock(11, databuff32(0)) 'MIFARE_WriteDataBlock(11, databuff32(0))
        If bOperResult <> 13 Then GoTo Err1:
        maSys_db.Execute "delete from Full_UserDict where userid='" & txtCardNo & "'"
        listrecord
        txtCardNo = ""
        MsgBox "删除成功！", vbInformation + vbOKOnly, "提示"
    Else
        maSys_db.Execute "delete from Full_UserDict where userid='" & txtCardNo & "'"
        listrecord
        txtCardNo = ""
        MsgBox "删除成功！", vbInformation + vbOKOnly, "提示"
    End If
    
End If
blOperResult = Disconnection()
Exit Sub

Err1:
MsgBox "删除失败！", vbInformation + vbOKOnly, "提示"
blOperResult = Disconnection()

End Sub

Private Sub Command1_Click()
Unload Me
End Sub

Private Sub Command2_Click() '验卡
Dim listcard As String
blOperResult = ConnectionUSBDevice()
If (blOperResult) Then
    
Else
    GoTo Err1:
End If
DoEvents

'先判断密码卡有决有装载过

'If Not KeyABP Then
    For i = 0 To 7
        KeyAP(i) = &H11
        KeyBP(i) = &H11
        KeyABP = True
    Next
'End If
''
bOperResult = MIFARE_SelectCard(SerialNum(0))
If bOperResult <> 0 Then
     GoTo Err1:
End If
CardId = Right("00" + hex(SerialNum(0)), 2) + Right("00" + hex(SerialNum(1)), 2) + Right("00" + hex(SerialNum(2)), 2) + Right("00" + hex(SerialNum(3)), 2)
txtCardID = CardId

For i = 0 To 3
    pbKeyID(i) = SerialNum(i)
    pbKeyID(i + 4) = SerialNum(i)
Next
'-----------------------------------------计算KEYA KEYB
st = ic_encrypt(KeyAP(0), pbKeyID(0), 8, pbExdest(0)) 'KEYA
If st <> 0 Then GoTo Err1:
For i = 0 To 5
    pbKeyA(i) = pbExdest(i)
Next

st = ic_encrypt(KeyBP(0), pbKeyID(0), 8, pbExdest(0)) 'KEYB
If st <> 0 Then GoTo Err1:
For i = 0 To 5
    pbKeyB(i) = pbExdest(i)
Next
'检验卡是否是新卡，如果不是，从数据库查询卡的信息

 '出厂卡密码
For i = 0 To 5
   pbKeyD(i) = &HFF
Next

bOperResult = MIFARE_LoginSector(2, 0, pbKeyD(0))
If bOperResult <> 0 Then '不是新卡
    bOperResult = MIFARE_SelectCard(SerialNum(0))
    bOperResult = MIFARE_LoginSector(2, 0, pbKeyA(0))
    If bOperResult <> 0 Then '不是发过的卡
         MsgBox "该卡不是系统内的卡！"
    Else '发过的卡
         'MIFARE_ReadDataBlock
        bOperResult = MIFARE_ReadDataBlock(8, databuff32(0))
        If bOperResult <> 0 Then GoTo Err1:
        stList = ""
        For n = 0 To 15
             stList = stList + Right("00" + hex(databuff32(n)), 2)
             
        Next n
        listcard = Mid(stList, 5, 2) + Mid(stList, 3, 2) + Mid(stList, 1, 2)
        txtCardNo.Text = Format(Hex2Dec(listcard), "000000")
        
        MsgBox "该卡是系统内的卡，卡号是：" + txtCardNo.Text, vbInformation + vbOKOnly, "提示信息"
    End If
Else '是新卡
    blOperResult = BuzzerSound(2)
    
    MsgBox "该卡是新卡！", vbInformation + vbOKOnly, "提示信息"
End If
blOperResult = Disconnection()
Exit Sub

Err1:
MsgBox "验卡错误！", vbInformation + vbOKOnly, "提示信息"
blOperResult = Disconnection()
End Sub

Private Sub Command3_Click() '查询
On Error GoTo err:
pssql = ""
If txtCardNo.Text <> "" Then
     pssql = "userid='" & txtCardNo & "' and"
End If

If txtName <> "" Then
    pssql = pssql & " username='" & txtName & "'"
End If

If Right(pssql, 3) = "and" Then
    pssql = Left(pssql, Len(pssql) - 4)
End If

If Len(pssql) <> 0 Then
    pssql = " where " & pssql
End If
pssql = "select * from full_userdict" & pssql

Set rs = GetRecordset(maSys_db, pssql)
If Not (rs.EOF And rs.BOF) Then
    listrecord
Else
    MsgBox "该卡号在数据库中不存在，请检查！", vbInformation + vbOKOnly, "提示"
End If

Exit Sub

err:
MsgBox "数据库错误！", vbInformation + vbOKOnly, "提示"
Exit Sub
End Sub

Private Sub Command4_Click() '手工登记
If Combo1.Text <> "" And txtCardNo.Text <> "" And txtName.Text <> "" Then
    Set rs = GetRecordset(maSys_db, "select *  from Full_UserDict where  userid='" & Trim(Format(txtCardNo, "000000")) & "'")
    If Not (rs.EOF And rs.BOF) Then
        MsgBox "该卡号在数据库中已经存在，请检查！", vbInformation + vbOKOnly, "提示"
    Else
        pscard.Open "select * from Full_UserDict", maSys_db, 3, 3
        pscard.AddNew
        pscard.Fields("userid") = Trim(txtCardNo)
        pscard.Fields("username") = Trim(txtName.Text)
        pscard.Fields("m1cardid") = "NULL"
        pscard.Fields("m1cardstate") = "启用"
        pscard.Fields("dept_name") = Combo1.Text
        pscard.Fields("settime") = Format(Now, "yyyy-mm-dd hh:mm:ss")
        pscard.Update
        pscard.Close
        MsgBox "发卡成功!", vbInformation + vbOKOnly, "提示"
        pssql = "select * from Full_UserDict order by userid"
        listrecord
        blOperResult = BuzzerSound(2)
    End If
Else
    MsgBox "输入不能为空，请输入...", vbInformation + vbOKOnly, "提示"
    txtCardNo.SetFocus
End If


GoTo Err1:
Exit Sub

err:
MsgBox "数据库错误！", vbInformation + vbOKOnly, "提示"
Exit Sub

Err1:
blOperResult = Disconnection()
End Sub

Private Sub Form_Load()
Me.Top = (Screen.Height - Me.Height) / 2 + 200
Me.Left = (Screen.Width - Me.Width) / 2
ListView1.Height = LinkMain.Height - 2.5 * Frame1.Height
pssql = "select * from Full_UserDict order by userid"
listrecord

Set rs = GetRecordset(maSys_db, "select * from dept_dict")
Combo1.Clear

Do While Not rs.EOF
    Combo1.AddItem rs.Fields("dept_name")
    rs.MoveNext
Loop
rs.Close
Combo1.ListIndex = 0

blOperResult = ConnectionUSBDevice()
If (blOperResult) Then
    Command2.Enabled = True
    cmdAdd.Enabled = True
    Command4.Enabled = False
    blOperResult = Disconnection()
Else
    Command2.Enabled = False
    cmdAdd.Enabled = False
    Command4.Enabled = True
    Option2.value = True
End If

DoEvents
End Sub

Private Sub listrecord()
Dim L As ListItem
Dim i As Integer

ListView1.ColumnHeaders.Clear
ListView1.ListItems.Clear
ListView1.View = lvwReport
ListView1.ColumnHeaders.Add , , "卡号", 1500
ListView1.ColumnHeaders.Add , , "姓名", 1800
ListView1.ColumnHeaders.Add , , "部门名称", 1900
ListView1.ColumnHeaders.Add , , "卡状态", 1200
ListView1.ColumnHeaders.Add , , "时间", 2600

Set rs = GetRecordset(maSys_db, pssql)
Do While Not rs.EOF
    Set L = ListView1.ListItems.Add(, "a" + CStr(i), CStr(rs!userid))
    'L.ForeColor = vbRed
    L.ListSubItems.Add , , rs!UserName
    L.ListSubItems.Add , , rs!dept_name
    L.ListSubItems.Add , , rs!m1cardstate
    L.ListSubItems.Add , , rs!SetTime
    rs.MoveNext
    i = i + 1
Loop
rs.Close
End Sub
    
Private Sub Form_Unload(Cancel As Integer)
quit
End Sub

Private Sub txtcardno_KeyPress(KeyAscii As Integer)
If KeyAscii > 57 Or KeyAscii < 48 And KeyAscii <> 8 Then
        KeyAscii = 0
End If
End Sub

Private Sub txtCardNo_LostFocus()
txtCardNo = Format(txtCardNo, "000000")
End Sub