vb6荣士读写器ISO-14443-A系列M1 S50、S70、F08卡源码

vx_13822155058
已于 2022-03-26 17:33:55 修改
阅读量472
点赞数
分类专栏： IC读写器 18002295132 QQ:954486673 文章标签： vb6读写s70卡 vb6 iso-14443-a vb6 MifareOne vb6 m1 vb6 RFID
于 2022-03-25 08:58:05 首次发布
本文链接：https://blog.csdn.net/zhangjin7422/article/details/123726558
版权
QQ:954486673 同时被 3 个专栏收录
127 篇文章 1 订阅
订阅专栏
18002295132
124 篇文章 1 订阅
订阅专栏
IC读写器
79 篇文章 5 订阅
订阅专栏
发卡器介绍：https://item.taobao.com/item.htm?spm=a1z10.5-c.w4002-17663462238.11.1d75789eyZBxwL&id=615391857885https://item.taobao.com/item.htm?spm=a1z10.5-c.w4002-17663462238.11.1d75789eyZBxwL&id=615391857885
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 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 oldkh As String

Private Sub Command1_Click()
Dim status As Byte '存放返回值
Dim myareano As Byte '区号
Dim authmode As Byte '密码类型，用A密码或B密码
Dim myctrlword As Byte '控制字
Dim mypicckey(0 To 5) As Byte '密码
Dim mypiccserial(0 To 3) As Byte '卡序列号
Dim mypiccdata(0 To 47) As Byte '卡数据缓冲
Dim myblockdata(0 To 15) As Byte '卡数据缓冲

'控制字指定,控制字的含义请查看本公司网站提供的动态库说明
myctrlword = BLOCK0_EN + BLOCK1_EN + BLOCK2_EN + EXTERNKEY

'指定区号
myareano = Combo2.ListIndex  '指定为第8区
'批定密码模式
authmode = Combo1.ListIndex  '大于0表示用A密码认证，推荐用A密码认证

'指定密码
mypicckey(0) = "&H" & Mid(Text5, 1, 2)
mypicckey(1) = "&H" & Mid(Text5, 3, 2)
mypicckey(2) = "&H" & Mid(Text5, 5, 2)
mypicckey(3) = "&H" & Mid(Text5, 7, 2)
mypicckey(4) = "&H" & Mid(Text5, 9, 2)
mypicckey(5) = "&H" & Mid(Text5, 11, 2)
            
Text3.Text = ""
Text1.Text = ""

status = piccreadex(myctrlword, VarPtr(mypiccserial(0)), myareano, authmode, VarPtr(mypicckey(0)), VarPtr(mypiccdata(0)))
            
'在下面设定断点，然后查看mypiccserial、mypiccdata，
'调用完 piccreadex函数可读出卡序列号到 mypiccserial，读出卡数据到mypiccdata，
'开发人员根据自己的需要处理mypiccserial、mypiccdata 中的数据了。
'处理返回函数
Select Case status
       Case 0:
            infstr = ""
            For j = 0 To 2
                For i = 0 To 15
                    infstr = infstr + Right("00" + Hex(mypiccdata(j * 16 + i)), 2) + " "
                Next i
            Next j
            Text3.Text = infstr
         
            infstr = ""
            status = piccread(myareano * 4 + 3, VarPtr(myblockdata(0)))
            If status = 0 Then
                For i = 0 To 15
                    infstr = infstr + Right("00" + Hex(myblockdata(i)), 2) + " "
                Next i
                Text1.Text = infstr
            End If
            pcdbeep 50
            MsgBox "操作成功"
       Case 8:    
            MsgBox "请将卡放在感应区"        
    Case 21 '没有动态库
            MsgBox "找不到动态库ICUSB.DLL请将ICUSB.DLL拷贝到VB安装后的目录VB98下"    
    Case Else
            MsgBox "异常" + Format(status, "0")
End Select
End Sub

Private Sub Command2_Click()
Dim writestr As String
Dim i As Integer

Dim status As Byte '存放返回值
Dim myareano As Byte '区号
Dim authmode As Byte '密码类型，用A密码或B密码
Dim myctrlword As Byte '控制字
Dim mypicckey(0 To 5) As Byte '密码
Dim mypiccserial(0 To 3) As Byte '卡序列号
Dim mypiccdata(0 To 47) As Byte '卡数据缓冲

writestr = Trim(Text3.Text)

If Len(Trim(writestr)) < 143 Then
    MsgBox "写卡数据不足，请补足写卡数据"
    Exit Sub
End If

On Error GoTo err1:

For i = 0 To 47
    mypiccdata(i) = "&H" + Mid(writestr, i * 3 + 1, 2)
Next i

'控制字指定,控制字的含义请查看本公司网站提供的动态库说明
myctrlword = BLOCK0_EN + BLOCK1_EN + BLOCK2_EN + EXTERNKEY

'指定区号
myareano = Combo2.ListIndex  '指定为第8区
'批定密码模式
authmode = Combo1.ListIndex  '大于0表示用A密码认证，推荐用A密码认证

'指定密码
mypicckey(0) = "&H" & Mid(Text5, 1, 2)
mypicckey(1) = "&H" & Mid(Text5, 3, 2)
mypicckey(2) = "&H" & Mid(Text5, 5, 2)
mypicckey(3) = "&H" & Mid(Text5, 7, 2)
mypicckey(4) = "&H" & Mid(Text5, 9, 2)
mypicckey(5) = "&H" & Mid(Text5, 11, 2)

status = piccwriteex(myctrlword, VarPtr(mypiccserial(0)), myareano, authmode, VarPtr(mypicckey(0)), VarPtr(mypiccdata(0)))
Select Case status
       Case 0:
            pcdbeep 50
            MsgBox "写卡成功"        
       Case 8:    
            MsgBox "请将卡放在感应区"        
    Case 21 '没有动态库
            MsgBox "找不到动态库ICUSB.DLL请将ICUSB.DLL拷贝到VB安装后的目录VB98下"    
    Case Else
            MsgBox "异常" + Format(status, "0")
End Select

Exit Sub

err1:
    MsgBox "写卡数据错误，请输入正确的16进制写卡数据"
End Sub


Private Sub Command6_Click()
Dim i As Integer
Dim status As Byte '存放返回值
Dim myareano As Byte '区号
Dim authmode As Byte '密码类型，用A密码或B密码
Dim myctrlword As Byte '控制字
Dim mypiccserial(0 To 3) As Byte '卡序列号
Dim mypiccoldkey(0 To 5) As Byte '旧密码
Dim mypiccnewkey(0 To 16) As Byte '新密码

'控制字指定,控制字的含义请查看本公司网站提供的动态库说明
myctrlword = BLOCK0_EN + BLOCK1_EN + BLOCK2_EN + EXTERNKEY

'指定区号
myareano = Combo2.ListIndex  '指定为第8区
'批定密码模式
authmode = Combo1.ListIndex  '大于0表示用A密码认证，推荐用A密码认证

'指定密码
 On Error GoTo err1:
 
mypiccoldkey(0) = "&H" & Mid(Text5, 1, 2)
mypiccoldkey(1) = "&H" & Mid(Text5, 3, 2)
mypiccoldkey(2) = "&H" & Mid(Text5, 5, 2)
mypiccoldkey(3) = "&H" & Mid(Text5, 7, 2)
mypiccoldkey(4) = "&H" & Mid(Text5, 9, 2)
mypiccoldkey(5) = "&H" & Mid(Text5, 11, 2)

'指定新密码,注意：指定新密码时一定要记住，否则有可能找不回密码，导致该卡报废。
newkey = Trim(Text1.Text)
For i = 0 To 15
    mypiccnewkey(i) = "&H" & Mid(newkey, i * 3 + 1, 2)
Next

mypiccnewkey(16) = &H3  '3是表示同时更改A、B、 密码权限访问字，为2表示密码权限访问字不更改，只改A、B密码，为0表示只改A密码

answ = MsgBox("您确定修改密码控制块的数据吗，此块数据如果改写了错误的数据卡片将报废！", vbQuestion + vbOKCancel, "警告")
If answ <> vbOK Then Exit Sub

status = piccchangesinglekeyex(myctrlword, VarPtr(mypiccserial(0)), myareano, authmode, VarPtr(mypiccoldkey(0)), VarPtr(mypiccnewkey(0)))

'处理返回函数
Select Case status
       Case 0:
            pcdbeep 50
            MsgBox "操作成功"        
       Case 8:    
            MsgBox "请将卡放在感应区"        
       Case 21 '没有动态库
            MsgBox "找不到动态库ICUSB.DLL请将ICUSB.DLL拷贝到VB安装后的目录VB98下"    
       Case Else
            MsgBox "异常" + Format(status, "0")
End Select

Exit Sub

err1:
    MsgBox "写卡数据错误，请输入正确的16进制写卡数据"
End Sub

Private Sub Form_Load()
Combo1.ListIndex = 1
Combo2.ListIndex = 16
End Sub


Private Sub Command17_Click() '读s70卡>=32的扇区
Dim status As Byte '存放返回值
Dim i, j, p As Integer
Dim myareano As Byte '区号
Dim authmode As Byte '密码类型，用A密码或B密码
Dim myctrlword As Byte '控制字
Dim mypicckey(0 To 5) As Byte '密码
Dim mypiccserial(0 To 3) As Byte '卡序列号
Dim mypiccdata(0 To 255) As Byte '卡数据缓冲
Dim myblockdata(0 To 15) As Byte '卡数据缓冲
Dim readinf  As String

'控制字指定,控制字的含义请查看本公司网站提供的动态库说明
myctrlword = BLOCK0_EN + BLOCK1_EN + BLOCK2_EN + EXTERNKEY

'指定区号
myareano = Val(Combo1.Text)  '指定区
'批定密码模式
authmode = 1 '大于0表示用A密码认证，推荐用A密码认证

'指定密码
mypicckey(0) = &HFF
mypicckey(1) = &HFF
mypicckey(2) = &HFF
mypicckey(3) = &HFF
mypicckey(4) = &HFF
mypicckey(5) = &HFF

Text3.Text = ""

status = piccreadex(myctrlword, VarPtr(mypiccserial(0)), myareano, authmode, VarPtr(mypicckey(0)), VarPtr(mypiccdata(0)))
'在下面设定断点，然后查看mypiccserial、mypiccdata，
'调用完 piccreadex函数可读出卡序列号到 mypiccserial，读出卡数据到mypiccdata，
'开发人员根据自己的需要处理mypiccserial、mypiccdata 中的数据了。
'处理返回函数
Select Case status
       Case 0:
            p = 48
            For i = 3 To 15
                status = piccread(128 + ((myareano - 32) * 16) + i, VarPtr(myblockdata(0)))
                If status = 0 Then
                    For j = 0 To 15
                        mypiccdata(p) = myblockdata(j)
                        p = p + 1
                    Next
                Else
                    MsgBox "读第" & Format(myareano * 4 + i, "0") & "块数据出错！"
                    Exit Sub
                End If
            Next
            readinf = ""
            For i = 0 To 239         '0-14块 数据块
                readinf = readinf + Format(Hex(mypiccdata(i)), "00")
            Next
            Text3.Text = readinf
        
            readinf = ""
            For i = 240 To 255     '15块密码控制块
                readinf = readinf + Format(Hex(mypiccdata(i)), "00")
            Next
            Text4.Text = readinf
        
            MsgBox "读卡成功"
       Case 8:    
            MsgBox "请将卡放在感应区"        
       Case 21 '没有动态库
            MsgBox "找不到动态库ICUSB.DLL请将ICUSB.DLL拷贝到VB安装后的目录VB98下"    
    Case Else
            MsgBox "异常"
End Select
End Sub


Private Sub Command18_Click()  '写s70卡>=32的扇区
Dim i, j, p As Integer
Dim status As Byte '存放返回值
Dim myareano As Byte '区号
Dim authmode As Byte '密码类型，用A密码或B密码
Dim myctrlword As Byte '控制字
Dim mypicckey(0 To 5) As Byte '密码
Dim mypiccserial(0 To 3) As Byte '卡序列号
Dim mypiccdata(0 To 47) As Byte '卡数据缓冲
Dim myblockdata(0 To 15) As Byte '卡数据缓冲
Dim writhdata(0 To 240) As Byte '卡数据缓冲
Dim writinf As String
        
'控制字指定,控制字的含义请查看本公司网站提供的动态库说明
myctrlword = BLOCK0_EN + BLOCK1_EN + BLOCK2_EN + EXTERNKEY

'指定区号
myareano = Val(Combo1.Text) '指定为第8区
'批定密码模式
authmode = 1 '大于0表示用A密码认证，推荐用A密码认证

'指定密码
mypicckey(0) = &HFF
mypicckey(1) = &HFF
mypicckey(2) = &HFF
mypicckey(3) = &HFF
mypicckey(4) = &HFF
mypicckey(5) = &HFF

writinf = Trim(Text3.Text)
For i = 0 To 239
    writinf = writinf + "00"
Next

'指定卡数据
For i = 0 To 239
    writhdata(i) = "&H" + Mid(writinf, i * 2 + 1, 2)
    If i <= 47 Then mypiccdata(i) = writhdata(i)
Next i

status = piccwriteex(myctrlword, VarPtr(mypiccserial(0)), myareano, authmode, VarPtr(mypicckey(0)), VarPtr(mypiccdata(0)))
'在下面设定断点，然后查看mypiccserial、mypiccdata，
'调用完 piccreadex函数可读出卡序列号到 mypiccserial，读出卡数据到mypiccdata，
'开发人员根据自己的需要处理mypiccserial、mypiccdata 中的数据了。
'处理返回函数
Select Case status
       Case 0:
            j = 0
            p = 3
            For i = 48 To 239
                 myblockdata(j) = writhdata(i)
                 j = j + 1
                If j = 16 Then
                    status = piccwrite(128 + ((myareano - 32) * 16) + p, VarPtr(myblockdata(0)))
                    If status = 0 Then
                        j = 0
                        p = p + 1
                    Else
                        MsgBox "写" & Format(128 + ((myareano - 32) * 16) + p, "0") & "块错误"
                        Exit Sub
                    End If
                End If
            Next
         
            pcdbeep 50
            MsgBox "操作成功"        
       Case 8:    
            MsgBox "请将卡放在感应区"        
       Case 21 '没有动态库
            MsgBox "找不到动态库ICUSB.DLL请将ICUSB.DLL拷贝到VB安装后的目录VB98下"    
       Case Else
            MsgBox "异常"
End Select

End Sub