VB6批量修改IC卡全部扇区密钥源码

本示例使用设备： Android Linux RFID读写器NFC发卡器WEB可编程NDEF文本/智能海报/-淘宝网 (taobao.com)

函数声明

Private Declare Function piccreadex Lib "OUR_MIFARE.dll" (ByVal ctrlword As Byte, ByVal serial As Long, ByVal area As Byte, ByVal keyA1B0 As Byte, ByVal picckey As Long, ByVal piccdata0_2 As Long) As Byte

'Close the comport
Private Declare Function piccwriteex Lib "OUR_MIFARE.dll" (ByVal ctrlword As Byte, ByVal serial As Long, ByVal area As Byte, ByVal keyA1B0 As Byte, ByVal picckey As Long, ByVal piccdata0_2 As Long) As Byte

'修改单区函数声明
Private Declare Function piccchangesinglekey Lib "OUR_MIFARE.dll" (ByVal ctrlword As Byte, ByVal serial As Long, ByVal area As Byte, ByVal keyA1B0 As Byte, ByVal piccoldkey As Long, ByVal piccnewkey As Long) As Byte

Private Declare Function piccchangesinglekeyex Lib "OUR_MIFARE.dll" (ByVal ctrlword As Byte, ByVal serial As Long, ByVal area As Byte, ByVal keyA1B0 As Byte, ByVal piccoldkey As Long, ByVal piccnewkey As Long) As Byte

'让设备发出声响函数声明
Private Declare Function pcdbeep Lib "OUR_MIFARE.dll" (ByVal xms As Long) As Byte

'读取设备编号函数声明
Private Declare Function pcdgetdevicenumber Lib "OUR_MIFARE.dll" (ByVal devicenumber As Long) As Byte

'寻卡并返回该卡的序列号
Private Declare Function piccrequest Lib "OUR_MIFARE.dll" (ByVal serial As Long) As Byte

'寻卡并选中指定序列号的IC卡，必须指定序列号
Private Declare Function piccrequestex Lib "OUR_MIFARE.dll" (ByVal serial As Long) As Byte

'将密码写入芯片内部保密性极高的只写区域，此函数写入密码仅仅是为了piccauthkey2函数的使用。
Private Declare Function pcdwritekeytoe2 Lib "OUR_MIFARE.dll" (ByVal area As Byte, ByVal keyA1B0 As Byte, ByVal picckey As Long) As Byte

'密码认证方式1，用外部密码认证，必须指定外部密码。本函数必须在piccrequest或piccrequestex函数执行之后运行，并且要紧接着调用，中途不能调用其他函数。
Private Declare Function piccauthkey1 Lib "OUR_MIFARE.dll" (ByVal serial As Long, ByVal area As Byte, ByVal keyA1B0 As Byte, ByVal picckey As Long) As Byte

'读出一块的数据，也就是16个字节。必须在执行piccrequest或 Piccrequestex函数，接着执行piccauthkey1或 piccauthkey2函数，然后执行piccread才能成功读出一块的数据。
Private Declare Function piccread Lib "OUR_MIFARE.dll" (ByVal block As Byte, ByVal piccdata As Long) As Byte

'写一块的数据，也就是16个字节。必须在执行piccrequest或 Piccrequestex函数，接着执行piccauthkey1或 piccauthkey2函数，然后执行piccread才能成功读出一块的数据。
Private Declare Function piccwrite Lib "OUR_MIFARE.dll" (ByVal block As Byte, ByVal piccdata As Long) As Byte

'读设备存储区1
Private Declare Function pcdgetcustomizedata1 Lib "OUR_MIFARE.dll" (ByVal readerdata As Long) As Byte

'写设备存储区1
Private Declare Function pcdsetcustomizedata1 Lib "OUR_MIFARE.dll" (ByVal readerdata As Long) As Byte


'读设备存储区2
Private Declare Function pcdgetcustomizedata2 Lib "OUR_MIFARE.dll" (ByVal readerdata As Long, ByVal devicenumber As Long) As Byte

'写设备存储区2
Private Declare Function pcdsetcustomizedata2 Lib "OUR_MIFARE.dll" (ByVal readerdata As Long) As Byte

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long

Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long


        
'控制字定义,控制字指定,控制字的含义请查看本公司网站提供的动态库说明
Private Const BLOCK0_EN = &H1
Private Const BLOCK1_EN = &H2
Private Const BLOCK2_EN = &H4
Private Const NEEDSERIAL = &H8
Private Const EXTERNKEY = &H10
Private Const NEEDHALT = &H20

Dim counstr As Integer
Dim lastuid As String

修改全部扇区密码

Private Sub Command2_Click()
Dim divstr, regstr, divreg As String
Dim devno(0 To 3) As Byte '设备编号
status = pcdgetdevicenumber(VarPtr(devno(0)))
If status = 0 Then
    divstr = Format(devno(0), "000") & "-" & Format(devno(1), "000") & "-" & Format(devno(2), "000") & "-" & Format(devno(3), "000")
    divreg = sGetINI(App.Path & "\SysConfig.ini", "DefaultSetup", "RegisterCode", "1234567890abcdef")
    regstr = DecryptStr(divreg)
    If divstr = regstr Then
        lastuid = ""
        If Command2.Caption = "修改选定扇区的卡密码" Then
            Command2.Caption = "停 止"
            For I = 0 To 15
                Text4(I).Text = ""
            Next
            Timer1.Enabled = True
        Else
            Timer1.Enabled = False
            Command2.Caption = "修改选定扇区的卡密码"
        End If
    Else
        Timer1.Enabled = False
        Command2.Caption = "修改选定扇区的卡密码"
        MsgBox ("设备编号：" & divstr & "，非本系统的注册设备，暂不能执行此功能！请将设备编号发给供应商申请注册码开通此功能！"), vbCritical + vbOKOnly, "提示"
    End If
Else
    Timer1.Enabled = False
    Command2.Caption = "修改选定扇区的卡密码"
    MsgBox ("系统未识别到发卡器，暂无法执行此功能！"), vbCritical + vbOKOnly, "提示"
End If
End Sub

Private Sub Timer1_Timer()
Dim I As Integer
Dim status As Byte '存放返回值
Dim myareano As Byte '区号
Dim authmode As Byte '密码类型，用A密码或B密码
Dim mypiccserial(0 To 3) As Byte
Dim mypiccoldkey(0 To 5) As Byte '旧密码
Dim mypiccnewkey(0 To 16) As Byte '新密码
Dim keystr, cardstr As String
    
Timer1.Enabled = False
If piccrequest(VarPtr(mypiccserial(0))) = 0 Then              'M1标签
    For I = 0 To 3
        cardstr = cardstr + Right("0" + Hex(mypiccserial(I)), 2)
    Next I
    
    If cardstr <> lastuid Then
        ListAddItem "寻找到新卡：" & cardstr & "，正在修改扇区密码及控制位，请不要移动卡片..."
        lastuid = cardstr
        
        For I = 0 To 15
            Text4(I).Text = ""
        Next

        For I = 0 To 15
            If Check4(I).Value > 0 Then
                myctrlword = BLOCK0_EN + BLOCK1_EN + BLOCK2_EN + EXTERNKEY
                myareano = I
                authmode = Combo16(I).ListIndex
                
                On Error GoTo err1:
                keystr = Trim(Text17(I).Text)
                mypiccoldkey(0) = "&H" & Mid(keystr, 1, 2)
                mypiccoldkey(1) = "&H" & Mid(keystr, 3, 2)
                mypiccoldkey(2) = "&H" & Mid(keystr, 5, 2)
                mypiccoldkey(3) = "&H" & Mid(keystr, 7, 2)
                mypiccoldkey(4) = "&H" & Mid(keystr, 9, 2)
                mypiccoldkey(5) = "&H" & Mid(keystr, 11, 2)
                
                On Error GoTo err2:
                keystr = Trim(Text1(I).Text)
                mypiccnewkey(0) = "&H" & Mid(keystr, 1, 2)
                mypiccnewkey(1) = "&H" & Mid(keystr, 3, 2)
                mypiccnewkey(2) = "&H" & Mid(keystr, 5, 2)
                mypiccnewkey(3) = "&H" & Mid(keystr, 7, 2)
                mypiccnewkey(4) = "&H" & Mid(keystr, 9, 2)
                mypiccnewkey(5) = "&H" & Mid(keystr, 11, 2)
                
                On Error GoTo err3:
                keystr = Trim(Text2(I).Text)
                mypiccnewkey(6) = "&H" & Mid(keystr, 1, 2)
                mypiccnewkey(7) = "&H" & Mid(keystr, 3, 2)
                mypiccnewkey(8) = "&H" & Mid(keystr, 5, 2)
                mypiccnewkey(9) = "&H" & Mid(keystr, 7, 2)
                
                On Error GoTo err4:
                keystr = Trim(Text3(I).Text)
                mypiccnewkey(10) = "&H" & Mid(keystr, 1, 2)
                mypiccnewkey(11) = "&H" & Mid(keystr, 3, 2)
                mypiccnewkey(12) = "&H" & Mid(keystr, 5, 2)
                mypiccnewkey(13) = "&H" & Mid(keystr, 7, 2)
                mypiccnewkey(14) = "&H" & Mid(keystr, 9, 2)
                mypiccnewkey(15) = "&H" & Mid(keystr, 11, 2)
                
                mypiccnewkey(16) = &H3  '3是表示同时更改A、B、 密码权限访问字，为2表示密码权限访问字不更改，只改A、B密码，为0表示只改A密码
        
                status = piccchangesinglekeyex(myctrlword, VarPtr(mypiccserial(0)), myareano, authmode, VarPtr(mypiccoldkey(0)), VarPtr(mypiccnewkey(0)))
                Select Case status
                    Case 0
                         Text4(I).Text = "扇区密码及控制位修改成功！"
                    Case 12
                         Text4(I).Text = "扇区密码认证失败！"
                    Case Else
                         Text4(I).Text = "操作失败，异常代码：" + Format(status, "0")
                End Select
            End If
        Next
        pcdbeep 50
    Else
        ListAddItem "请在感应区刷新的卡"
    End If
Else
    ListAddItem "请在感应区刷新的卡"
End If

Timer1.Enabled = True
Exit Sub

err1:
    Command2.Caption = "修改选定扇区的卡密码"
    MsgBox (Format(I, "00") & " 区旧认证密码输入错误！"), vbCritical + vbOKOnly, "提示"
    Exit Sub
    
err2:
    Command2.Caption = "修改选定扇区的卡密码"
    MsgBox (Format(I, "00") & " 区新A密码输入错误！"), vbCritical + vbOKOnly, "提示"
    Exit Sub
    
err3:
    Command2.Caption = "修改选定扇区的卡密码"
    MsgBox (Format(I, "00") & " 区新控制位输入错误！"), vbCritical + vbOKOnly, "提示"
    Exit Sub
    
err4:
    Command2.Caption = "修改选定扇区的卡密码"
    MsgBox (Format(I, "00") & " 区新B密码输入错误！"), vbCritical + vbOKOnly, "提示"
    Exit Sub
           
End Sub