VB6轻松读写nfc forum type 4 NDEF标签源码
NDEF 全称 NFC data exchange format 即 nfc 数据交换格式，是一种标准化的数据格式，可用于在任何兼容的NFC设备与另一个NFC设备或标签之间交换信息。数据格式由NDEF消息和NDEF记录组成。
本示例使用的发卡器：Android Linux RFID读写器NFC发卡器WEB可编程NDEF文本/智能海报/-淘宝网 (taobao.com)
Option Explicit
'让设备发出声响函数声明
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 Const NEEDSERIAL = &H8
Private Const NEEDKEY = &H10
Private Const NEEDHALT = &H20
'智能海报
Private Declare Sub tagbuf_clear Lib "OUR_MIFARE.dll" ()
Private Declare Function tagbuf_addtext Lib "OUR_MIFARE.dll" (ByVal languagecodestr As String, ByVal languagecodestrlen As Long, ByVal textstr As String, ByVal textstrlen As Long) As Byte
Private Declare Function tagbuf_adduri Lib "OUR_MIFARE.dll" (ByVal languagecodestr As String, ByVal languagecodestrlen As Long, ByVal titlestr As String, ByVal titlestrlen As Long, ByVal uriheaderindex As Long, ByVal uristr As String, ByVal uristrlen As Long) As Byte
Private Declare Function tagbuf_addbusinesscard Lib "OUR_MIFARE.dll" (ByVal infostr As String, ByVal infostrlen As Long) As Byte
Private Declare Function tagbuf_addwifi Lib "OUR_MIFARE.dll" (ByVal ssidstr As String, ByVal ssidstrlen As Long, ByVal authtype As Long, ByVal crypttype As Long, ByVal keystr As String, ByVal keystrlen As Long) As Byte
Private Declare Function tagbuf_addbluetooth Lib "OUR_MIFARE.dll" (ByVal blenamestr As String, ByVal blenamestrlen As Long, ByRef blemac As Byte) As Byte
Private Declare Function tagbuf_addapp Lib "OUR_MIFARE.dll" (ByVal packagestr As String, ByVal packagestrlen As Long) As Byte
Private Declare Function tagbuf_adddata Lib "OUR_MIFARE.dll" (ByVal typestr As String, ByVal typestrlen As Long, ByVal datastr As String, ByVal datastrlen As Long) As Byte
'M1卡 操作
Private Declare Function piccclear_ndeftag Lib "OUR_MIFARE.dll" (ByVal ctrlword As Byte, ByRef serial As Byte, ByRef oldkey As Byte) As Byte
Private Declare Function piccwrite_ndeftag Lib "OUR_MIFARE.dll" (ByVal ctrlword As Byte, ByRef serial As Byte, ByRef oldkey As Byte, ByRef newkey As Byte) As Byte
'NFC Forum Type 4 tag格式操作
Private Declare Sub tagbuf_forumtype4_clear Lib "OUR_MIFARE.dll" ()
Private Declare Function forumtype4request Lib "OUR_MIFARE.dll" (ByVal ctrlword As Byte, ByRef serial As Byte, ByRef seriallen As Byte) As Byte
Private Declare Function forumtype4_write_ndeftag Lib "OUR_MIFARE.dll" (ByVal ctrlword As Byte, ByRef serial As Byte, ByRef seriallen As Byte, ByRef ndefwritekey As Byte) As Byte
Private Sub Combo1_Click()
Select Case Combo1.ListIndex
Case 0:
Label14.Caption = "由于无前缀，请输入完整的地址"
Case 1
Label14.Caption = "例如：baidu.com"
Case 2
Label14.Caption = "例如：baidu.com"
Case Else
Label14.Caption = ""
End Select
End Sub
Private Sub Combo4_Click()
Dim packagestr(0 To 14) As String
packagestr(0) = "com.tencent.mobileqq"
packagestr(1) = "com.android.mms"
packagestr(2) = "com.android.camera"
packagestr(3) = "com.tencent.mm"
packagestr(4) = "com.alibaba.android.rimet"
packagestr(5) = "com.taobao.taobao"
packagestr(6) = "com.taobao.qianniu"
packagestr(7) = "com.fcbox.hiveconsumer"
packagestr(8) = "com.eg.android.AlipayGphone"
packagestr(9) = "com.android.contacts"
packagestr(10) = "com.baidu.BaiduMap"
packagestr(11) = "com.kugou.android"
packagestr(12) = "com.cebbank.mobile.cemb"
packagestr(13) = "com.netease.newsreader.activity"
packagestr(14) = "com.icbc"
If Combo4.ListIndex < 15 Then
Text23.Text = packagestr(Combo4.ListIndex)
End If
End Sub
Private Sub Command1_Click() '将链接写入卡片
'技术支持:
'网站:
Dim status As Byte '存放返回值
Dim myctrlword As Byte
Dim i As Integer
Dim mypiccserial(0 To 6) As Byte '卡序列号
Dim mypiccseriallen(1) As Byte '卡序列号字节数
Dim picckey(0 To 15) As Byte '需要认证的密码
Dim str As String
Dim strls1 As String
Dim strls2 As String
Dim strlen As Integer '数据字符串的长度
Dim languagecodestr As String
Dim languagecodestrlen As Long
Dim titlestr As String
Dim titlestrlen As Long
Dim uriheaderindex As Long
Dim uristr As String
Dim uristrlen As Long
'语言编码，英文为en,中文为zh
languagecodestr = "en"
languagecodestrlen = 2
'标题
titlestr = Text3.Text
titlestrlen = LenB(StrConv(titlestr, vbFromUnicode))
'链接前缀
uriheaderindex = Combo1.ListIndex
'链接
uristr = Text4.Text
uristrlen = LenB(StrConv(uristr, vbFromUnicode))
tagbuf_forumtype4_clear
status = tagbuf_adduri(languagecodestr, languagecodestrlen, titlestr, titlestrlen, uriheaderindex, uristr, uristrlen)
'可以写入多条记录
'status = tagbuf_adduri(languagecodestr, languagecodestrlen, titlestr, titlestrlen, uriheaderindex, uristr, uristrlen) '第二条记录
'status = tagbuf_adduri(languagecodestr, languagecodestrlen, titlestr, titlestrlen, uriheaderindex, uristr, uristrlen) '第三条记录
'status = tagbuf_adduri(languagecodestr, languagecodestrlen, titlestr, titlestrlen, uriheaderindex, uristr, uristrlen) '第四条记录
If (status > 0) Then
MsgBox "异常：" + CStr(status)
Exit Sub
End If
'密码
If (Check1.Value > 0) Then
strls1 = Text1.Text
strlen = Len(strls1)
str = ""
For i = 1 To strlen
strls2 = Mid(strls1, i, 1)
If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblf
str = str + strls2
End If
Next i
strlen = Len(str)
If strlen < 32 Then
MsgBox "密码长度不足"
Text1.SetFocus
Exit Sub
End If
strlen = 0
For i = 1 To 32 Step 2
strls2 = Mid(str, i, 2)
picckey(strlen) = CByte("&h" & strls2)
strlen = strlen + 1
Next i
myctrlword = &H40
Else
myctrlword = &H0
End If
status = forumtype4_write_ndeftag(myctrlword, mypiccserial(0), mypiccseriallen(0), picckey(0))
Select Case status
Case 0:
For i = 0 To (mypiccseriallen(0) - 1)
str = str + Right("0" + Hex(mypiccserial(i)), 2)
Next i
pcdbeep 38
MsgBox "写卡成功！卡号：" & str
Case 8:
MsgBox "请将卡放在感应区"
Case 23: '没有动态库
MsgBox "请连上USB 读写器"
Case 57: '卡片不支持功能
MsgBox "卡片不支持Forum_Type4协议，可能不是Forum_Type4_Tag卡"
Case Else
MsgBox "异常：" + CStr(status)
End Select
'返回解释
'#define ERR_REQUEST 8'寻卡错误
'#define ERR_READSERIAL 9'读序列吗错误
'#define ERR_SELECTCARD 10'选卡错误
'#define ERR_LOADKEY 11'装载密码错误
'#define ERR_AUTHKEY 12'密码认证错误
'#define ERR_READ 13'读卡错误
'#define ERR_WRITE 14'写卡错误
'#define ERR_NONEDLL 21'没有动态库
'#define ERR_DRIVERORDLL 22'动态库或驱动程序异常
'#define ERR_DRIVERNULL 23'驱动程序错误或尚未安装
'#define ERR_TIMEOUT 24'操作超时，一般是动态库没有反映
'#define ERR_TXSIZE 25'发送字数不够
'#define ERR_TXCRC 26'发送的CRC错
'#define ERR_RXSIZE 27'接收的字数不够
'#define ERR_RXCRC 28'接收的CRC错
End Sub
Private Sub Command10_Click() '蓝牙 写入卡片
'技术支持:
'网站:
Dim status As Byte '存放返回值
Dim myctrlword As Byte
Dim i As Integer
Dim mypiccserial(0 To 6) As Byte '卡序列号
Dim mypiccseriallen(1) As Byte '卡序列号字节数
Dim picckey(0 To 15) As Byte '需要认证的密码
Dim str As String
Dim strls1 As String
Dim strls2 As String
Dim strlen As Integer '数据字符串的长度
Dim blenamestr As String
Dim blenamestrlen As Long
'蓝牙MAC地址
Dim blemac(0 To 5) As Byte '蓝牙MAC地址
'蓝牙设备名称
blenamestr = Text21.Text
blenamestrlen = LenB(StrConv(blenamestr, vbFromUnicode))
'蓝牙MAC地址
strls1 = Text22.Text
strlen = Len(strls1)
str = ""
For i = 1 To strlen
strls2 = Mid(strls1, i, 1)
If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblf
str = str + strls2
End If
Next i
strlen = Len(str)
If strlen < 12 Then
MsgBox "蓝牙MAC地址长度不足"
Text1.SetFocus
Exit Sub
End If
strlen = 0
For i = 1 To 12 Step 2
strls2 = Mid(str, i, 2)
blemac(strlen) = CByte("&h" & strls2)
strlen = strlen + 1
Next i
tagbuf_forumtype4_clear
status = tagbuf_addbluetooth(blenamestr, blenamestrlen, blemac(0))
'可以写入多条记录
If (status > 0) Then
MsgBox "异常：" + CStr(status)
Exit Sub
End If
'密码
If (Check1.Value > 0) Then
strls1 = Text1.Text
strlen = Len(strls1)
str = ""
For i = 1 To strlen
strls2 = Mid(strls1, i, 1)
If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblf
str = str + strls2
End If
Next i
strlen = Len(str)
If strlen < 32 Then
MsgBox "密码长度不足"
Text1.SetFocus
Exit Sub
End If
strlen = 0
For i = 1 To 32 Step 2
strls2 = Mid(str, i, 2)
picckey(strlen) = CByte("&h" & strls2)
strlen = strlen + 1
Next i
myctrlword = &H40
Else
myctrlword = &H0
End If
status = forumtype4_write_ndeftag(myctrlword, mypiccserial(0), mypiccseriallen(0), picckey(0))
Select Case status
Case 0:
For i = 0 To (mypiccseriallen(0) - 1)
str = str + Right("0" + Hex(mypiccserial(i)), 2)
Next i
pcdbeep 38
MsgBox "写卡成功！卡号：" & str
Case 8:
MsgBox "请将卡放在感应区"
Case 23: '没有动态库
MsgBox "请连上USB 读写器"
Case 57: '卡片不支持功能
MsgBox "卡片不支持Forum_Type4协议，可能不是Forum_Type4_Tag卡"
Case Else
MsgBox "异常：" + CStr(status)
End Select
End Sub
Private Sub Command11_Click() 'WIFI 写入卡片
'技术支持:
'网站:
Dim status As Byte '存放返回值
Dim myctrlword As Byte
Dim i As Integer
Dim mypiccserial(0 To 6) As Byte '卡序列号
Dim mypiccseriallen(1) As Byte '卡序列号字节数
Dim picckey(0 To 15) As Byte '需要认证的密码
Dim str As String
Dim strls1 As String
Dim strls2 As String
Dim strlen As Integer '数据字符串的长度
Dim ssidstr As String
Dim ssidstrlen As Long
Dim authtype As Long
Dim crypttype As Long
Dim keystr As String
Dim keystrlen As Long
'WIFI名称
ssidstr = Text18.Text
ssidstrlen = LenB(StrConv(ssidstr, vbFromUnicode))
'加密方式
authtype = Combo2.ListIndex
'加密算法
crypttype = Combo3.ListIndex
'密码
keystr = Text17.Text
keystrlen = LenB(StrConv(keystr, vbFromUnicode))
tagbuf_forumtype4_clear
status = tagbuf_addwifi(ssidstr, ssidstrlen, authtype, crypttype, keystr, keystrlen)
'可以写入多条记录
If (status > 0) Then
MsgBox "异常：" + CStr(status)
Exit Sub
End If
'密码
If (Check1.Value > 0) Then
strls1 = Text1.Text
strlen = Len(strls1)
str = ""
For i = 1 To strlen
strls2 = Mid(strls1, i, 1)
If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblf
str = str + strls2
End If
Next i
strlen = Len(str)
If strlen < 32 Then
MsgBox "密码长度不足"
Text1.SetFocus
Exit Sub
End If
strlen = 0
For i = 1 To 32 Step 2
strls2 = Mid(str, i, 2)
picckey(strlen) = CByte("&h" & strls2)
strlen = strlen + 1
Next i
myctrlword = &H40
Else
myctrlword = &H0
End If
status = forumtype4_write_ndeftag(myctrlword, mypiccserial(0), mypiccseriallen(0), picckey(0))
Select Case status
Case 0:
For i = 0 To (mypiccseriallen(0) - 1)
str = str + Right("0" + Hex(mypiccserial(i)), 2)
Next i
pcdbeep 38
MsgBox "写卡成功！卡号：" & str
Case 8:
MsgBox "请将卡放在感应区"
Case 23: '没有动态库
MsgBox "请连上USB 读写器"
Case 57: '卡片不支持功能
MsgBox "卡片不支持Forum_Type4协议，可能不是Forum_Type4_Tag卡"
Case Else
MsgBox "异常：" + CStr(status)
End Select
End Sub
Private Sub Command12_Click() '将地理位置写入卡片
'技术支持:
'网站:
Dim status As Byte '存放返回值
Dim myctrlword As Byte
Dim i As Integer
Dim mypiccserial(0 To 6) As Byte '卡序列号
Dim mypiccseriallen(1) As Byte '卡序列号字节数
Dim picckey(0 To 15) As Byte '需要认证的密码
Dim str As String
Dim strls1 As String
Dim strls2 As String
Dim strlen As Integer '数据字符串的长度
Dim languagecodestr As String
Dim languagecodestrlen As Long
Dim titlestr As String
Dim titlestrlen As Long
Dim uriheaderindex As Long
Dim uristr As String
Dim uristrlen As Long
'语言编码，英文为en,中文为zh
languagecodestr = "en"
languagecodestrlen = 2
'标题
titlestr = Text6.Text
titlestrlen = LenB(StrConv(titlestr, vbFromUnicode))
'地理位置没有链接前缀
uriheaderindex = 0
'地址位置
uristr = "geo:" + Text8.Text + "," + Text7.Text
uristrlen = LenB(StrConv(uristr, vbFromUnicode))
tagbuf_forumtype4_clear
status = tagbuf_adduri(languagecodestr, languagecodestrlen, titlestr, titlestrlen, uriheaderindex, uristr, uristrlen)
If (status > 0) Then
MsgBox "异常：" + CStr(status)
Exit Sub
End If
'密码
If (Check1.Value > 0) Then
strls1 = Text1.Text
strlen = Len(strls1)
str = ""
For i = 1 To strlen
strls2 = Mid(strls1, i, 1)
If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblf
str = str + strls2
End If
Next i
strlen = Len(str)
If strlen < 32 Then
MsgBox "密码长度不足"
Text1.SetFocus
Exit Sub
End If
strlen = 0
For i = 1 To 32 Step 2
strls2 = Mid(str, i, 2)
picckey(strlen) = CByte("&h" & strls2)
strlen = strlen + 1
Next i
myctrlword = &H40
Else
myctrlword = &H0
End If
status = forumtype4_write_ndeftag(myctrlword, mypiccserial(0), mypiccseriallen(0), picckey(0))
Select Case status
Case 0:
For i = 0 To (mypiccseriallen(0) - 1)
str = str + Right("0" + Hex(mypiccserial(i)), 2)
Next i
pcdbeep 38
MsgBox "写卡成功！卡号：" & str
Case 8:
MsgBox "请将卡放在感应区"
Case 23: '没有动态库
MsgBox "请连上USB 读写器"
Case 57: '卡片不支持功能
MsgBox "卡片不支持Forum_Type4协议，可能不是Forum_Type4_Tag卡"
Case Else
MsgBox "异常：" + CStr(status)
End Select
'返回解释
'#define ERR_REQUEST 8'寻卡错误
'#define ERR_READSERIAL 9'读序列吗错误
'#define ERR_SELECTCARD 10'选卡错误
'#define ERR_LOADKEY 11'装载密码错误
'#define ERR_AUTHKEY 12'密码认证错误
'#define ERR_READ 13'读卡错误
'#define ERR_WRITE 14'写卡错误
'#define ERR_NONEDLL 21'没有动态库
'#define ERR_DRIVERORDLL 22'动态库或驱动程序异常
'#define ERR_DRIVERNULL 23'驱动程序错误或尚未安装
'#define ERR_TIMEOUT 24'操作超时，一般是动态库没有反映
'#define ERR_TXSIZE 25'发送字数不够
'#define ERR_TXCRC 26'发送的CRC错
'#define ERR_RXSIZE 27'接收的字数不够
'#define ERR_RXCRC 28'接收的CRC错
End Sub
Private Sub Command14_Click() 'APP应用自启 写入卡片
'技术支持:
'网站:
Dim status As Byte '存放返回值
Dim myctrlword As Byte
Dim i As Integer
Dim mypiccserial(0 To 6) As Byte '卡序列号
Dim mypiccseriallen(1) As Byte '卡序列号字节数
Dim picckey(0 To 15) As Byte '需要认证的密码
Dim str As String
Dim strls1 As String
Dim strls2 As String
Dim strlen As Integer '数据字符串的长度
Dim packagestr As String
Dim packagestrlen As Long
packagestr = Text23.Text
packagestrlen = LenB(StrConv(packagestr, vbFromUnicode))
tagbuf_forumtype4_clear
status = tagbuf_addapp(packagestr, packagestrlen)
'可以写入多条记录
If (status > 0) Then
MsgBox "异常：" + CStr(status)
Exit Sub
End If
'密码
If (Check1.Value > 0) Then
strls1 = Text1.Text
strlen = Len(strls1)
str = ""
For i = 1 To strlen
strls2 = Mid(strls1, i, 1)
If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblf
str = str + strls2
End If
Next i
strlen = Len(str)
If strlen < 32 Then
MsgBox "密码长度不足"
Text1.SetFocus
Exit Sub
End If
strlen = 0
For i = 1 To 32 Step 2
strls2 = Mid(str, i, 2)
picckey(strlen) = CByte("&h" & strls2)
strlen = strlen + 1
Next i
myctrlword = &H40
Else
myctrlword = &H0
End If
status = forumtype4_write_ndeftag(myctrlword, mypiccserial(0), mypiccseriallen(0), picckey(0))
Select Case status
Case 0:
For i = 0 To (mypiccseriallen(0) - 1)
str = str + Right("0" + Hex(mypiccserial(i)), 2)
Next i
pcdbeep 38
MsgBox "写卡成功！卡号：" & str
Case 8:
MsgBox "请将卡放在感应区"
Case 23: '没有动态库
MsgBox "请连上USB 读写器"
Case 57: '卡片不支持功能
MsgBox "卡片不支持Forum_Type4协议，可能不是Forum_Type4_Tag卡"
Case Else
MsgBox "异常：" + CStr(status)
End Select
End Sub
Private Sub Command15_Click() '数据 写入卡片
'技术支持:
'网站:
Dim status As Byte '存放返回值
Dim myctrlword As Byte
Dim i As Integer
Dim mypiccserial(0 To 6) As Byte '卡序列号
Dim mypiccseriallen(1) As Byte '卡序列号字节数
Dim picckey(0 To 15) As Byte '需要认证的密码
Dim str As String
Dim strls1 As String
Dim strls2 As String
Dim strlen As Integer '数据字符串的长度
Dim typestr As String
Dim typestrlen As Long
Dim datastr As String
Dim datastrlen As Long
typestr = Text20.Text
typestrlen = LenB(StrConv(typestr, vbFromUnicode))
datastr = Text19.Text
datastrlen = LenB(StrConv(datastr, vbFromUnicode))
tagbuf_forumtype4_clear
status = tagbuf_adddata(typestr, typestrlen, datastr, datastrlen)
'可以写入多条记录
If (status > 0) Then
MsgBox "异常：" + CStr(status)
Exit Sub
End If
'密码
If (Check1.Value > 0) Then
strls1 = Text1.Text
strlen = Len(strls1)
str = ""
For i = 1 To strlen
strls2 = Mid(strls1, i, 1)
If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblf
str = str + strls2
End If
Next i
strlen = Len(str)
If strlen < 32 Then
MsgBox "密码长度不足"
Text1.SetFocus
Exit Sub
End If
strlen = 0
For i = 1 To 32 Step 2
strls2 = Mid(str, i, 2)
picckey(strlen) = CByte("&h" & strls2)
strlen = strlen + 1
Next i
myctrlword = &H40
Else
myctrlword = &H0
End If
status = forumtype4_write_ndeftag(myctrlword, mypiccserial(0), mypiccseriallen(0), picckey(0))
Select Case status
Case 0:
For i = 0 To (mypiccseriallen(0) - 1)
str = str + Right("0" + Hex(mypiccserial(i)), 2)
Next i
pcdbeep 38
MsgBox "写卡成功！卡号：" & str
Case 8:
MsgBox "请将卡放在感应区"
Case 23: '没有动态库
MsgBox "请连上USB 读写器"
Case 57: '卡片不支持功能
MsgBox "卡片不支持Forum_Type4协议，可能不是Forum_Type4_Tag卡"
Case Else
MsgBox "异常：" + CStr(status)
End Select
End Sub
Private Sub Command2_Click() '将纯文本写入卡片
'技术支持:
'网站:
Dim status As Byte '存放返回值
Dim myctrlword As Byte
Dim i As Integer
Dim mypiccserial(0 To 6) As Byte '卡序列号
Dim mypiccseriallen(1) As Byte '卡序列号字节数
Dim picckey(0 To 15) As Byte '需要认证的密码
Dim str As String
Dim strls1 As String
Dim strls2 As String
Dim strlen As Integer '数据字符串的长度
Dim languagecodestr As String
Dim languagecodestrlen As Long
Dim textstr As String
Dim textstrlen As Long
Dim uriheaderindex As Long
'语言编码，英文为en,中文为zh
languagecodestr = "en"
languagecodestrlen = 2
'文本
textstr = Text5.Text
textstrlen = LenB(StrConv(textstr, vbFromUnicode))
tagbuf_forumtype4_clear
status = tagbuf_addtext(languagecodestr, languagecodestrlen, textstr, textstrlen)
If (status > 0) Then
MsgBox "异常：" + CStr(status)
Exit Sub
End If
'密码
If (Check1.Value > 0) Then
strls1 = Text1.Text
strlen = Len(strls1)
str = ""
For i = 1 To strlen
strls2 = Mid(strls1, i, 1)
If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblf
str = str + strls2
End If
Next i
strlen = Len(str)
If strlen < 32 Then
MsgBox "密码长度不足"
Text1.SetFocus
Exit Sub
End If
strlen = 0
For i = 1 To 32 Step 2
strls2 = Mid(str, i, 2)
picckey(strlen) = CByte("&h" & strls2)
strlen = strlen + 1
Next i
myctrlword = &H40
Else
myctrlword = &H0
End If
status = forumtype4_write_ndeftag(myctrlword, mypiccserial(0), mypiccseriallen(0), picckey(0))
Select Case status
Case 0:
For i = 0 To (mypiccseriallen(0) - 1)
str = str + Right("0" + Hex(mypiccserial(i)), 2)
Next i
pcdbeep 38
MsgBox "写卡成功！卡号：" & str
Case 8:
MsgBox "请将卡放在感应区"
Case 23: '没有动态库
MsgBox "请连上USB 读写器"
Case 57: '卡片不支持功能
MsgBox "卡片不支持Forum_Type4协议，可能不是Forum_Type4_Tag卡"
Case Else
MsgBox "异常：" + CStr(status)
End Select
'返回解释
'#define ERR_REQUEST 8'寻卡错误
'#define ERR_READSERIAL 9'读序列吗错误
'#define ERR_SELECTCARD 10'选卡错误
'#define ERR_LOADKEY 11'装载密码错误
'#define ERR_AUTHKEY 12'密码认证错误
'#define ERR_READ 13'读卡错误
'#define ERR_WRITE 14'写卡错误
'#define ERR_NONEDLL 21'没有动态库
'#define ERR_DRIVERORDLL 22'动态库或驱动程序异常
'#define ERR_DRIVERNULL 23'驱动程序错误或尚未安装
'#define ERR_TIMEOUT 24'操作超时，一般是动态库没有反映
'#define ERR_TXSIZE 25'发送字数不够
'#define ERR_TXCRC 26'发送的CRC错
'#define ERR_RXSIZE 27'接收的字数不够
'#define ERR_RXCRC 28'接收的CRC错
End Sub
Private Sub Command3_Click() '寻卡
'技术支持:
'网站:
Dim status As Byte '存放返回值
Dim myctrlword As Byte
Dim i As Integer
Dim mypiccserial(0 To 6) As Byte '卡序列号
Dim mypiccseriallen(1) As Byte '卡序列号字节数
Dim str As String
'ctrlword:bit3指定卡，bit4为1函数指定密码为0表示内部密码，bit5操作完后休眠卡,bit6用指定密码写卡，bit7尝试NFC默认密码写卡,如果bit6和bit7都为1，表示先要指定密码写卡，如果不对就用NFC默认密码
'bit2为1写卡后同时将B密码改为newkey指定的密码。
status = forumtype4request(myctrlword, mypiccserial(0), mypiccseriallen(0))
Select Case status
Case 0, 52: 'Case Is = 0, Is = 52:
For i = 0 To (mypiccseriallen(0) - 1)
str = str + Right("0" + Hex(mypiccserial(i)), 2)
Next i
pcdbeep 38
MsgBox "寻卡成功！卡号：" & str
Case 8:
MsgBox "请将卡放在感应区"
Case 23: '没有动态库
MsgBox "请连上USB 读写器"
Case Else
MsgBox "异常：" + CStr(status)
End Select
End Sub
Private Sub Command4_Click()
'让设备发出声音
'技术支持:
'网站:
pcdbeep 50
End Sub
Private Sub Command5_Click()
'读取设备编号，可做为软件加密狗用,也可以根据此编号在公司网站上查询保修期限
'技术支持:
'网站:
Dim status As Byte
Dim devno(0 To 3) As Byte '设备编号
status = pcdgetdevicenumber(VarPtr(devno(0)))
If status = 0 Then
MsgBox CStr(devno(0)) + "-" + CStr(devno(1)) + "-" + CStr(devno(2)) + "-" + CStr(devno(3))
End If
'返回解释
'#define ERR_REQUEST 8'寻卡错误
'#define ERR_READSERIAL 9'读序列吗错误
'#define ERR_SELECTCARD 10'选卡错误
'#define ERR_LOADKEY 11'装载密码错误
'#define ERR_AUTHKEY 12'密码认证错误
'#define ERR_READ 13'读卡错误
'#define ERR_WRITE 14'写卡错误
'#define ERR_NONEDLL 21'没有动态库
'#define ERR_DRIVERORDLL 22'动态库或驱动程序异常
'#define ERR_DRIVERNULL 23'驱动程序错误或尚未安装
'#define ERR_TIMEOUT 24'操作超时，一般是动态库没有反映
'#define ERR_TXSIZE 25'发送字数不够
'#define ERR_TXCRC 26'发送的CRC错
'#define ERR_RXSIZE 27'接收的字数不够
'#define ERR_RXCRC 28'接收的CRC错
End Sub
Private Sub Command6_Click() '电话 写入卡片
'技术支持:
'网站:
Dim status As Byte '存放返回值
Dim myctrlword As Byte
Dim i As Integer
Dim mypiccserial(0 To 6) As Byte '卡序列号
Dim mypiccseriallen(1) As Byte '卡序列号字节数
Dim picckey(0 To 15) As Byte '需要认证的密码
Dim str As String
Dim strls1 As String
Dim strls2 As String
Dim strlen As Integer '数据字符串的长度
Dim languagecodestr As String
Dim languagecodestrlen As Long
Dim uristr As String
Dim uristrlen As Long
'语言编码，英文为en,中文为zh
languagecodestr = "en"
languagecodestrlen = 2
'链接
uristr = Text9.Text
uristrlen = LenB(StrConv(uristr, vbFromUnicode))
tagbuf_forumtype4_clear
status = tagbuf_adduri(languagecodestr, languagecodestrlen, "", 0, 5, uristr, uristrlen)
If (status > 0) Then
MsgBox "异常：" + CStr(status)
Exit Sub
End If
'密码
If (Check1.Value > 0) Then
strls1 = Text1.Text
strlen = Len(strls1)
str = ""
For i = 1 To strlen
strls2 = Mid(strls1, i, 1)
If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblf
str = str + strls2
End If
Next i
strlen = Len(str)
If strlen < 32 Then
MsgBox "密码长度不足"
Text1.SetFocus
Exit Sub
End If
strlen = 0
For i = 1 To 32 Step 2
strls2 = Mid(str, i, 2)
picckey(strlen) = CByte("&h" & strls2)
strlen = strlen + 1
Next i
myctrlword = &H40
Else
myctrlword = &H0
End If
status = forumtype4_write_ndeftag(myctrlword, mypiccserial(0), mypiccseriallen(0), picckey(0))
Select Case status
Case 0:
For i = 0 To (mypiccseriallen(0) - 1)
str = str + Right("0" + Hex(mypiccserial(i)), 2)
Next i
pcdbeep 38
MsgBox "写卡成功！卡号：" & str
Case 8:
MsgBox "请将卡放在感应区"
Case 23: '没有动态库
MsgBox "请连上USB 读写器"
Case 57: '卡片不支持功能
MsgBox "卡片不支持Forum_Type4协议，可能不是Forum_Type4_Tag卡"
Case Else
MsgBox "异常：" + CStr(status)
End Select
End Sub
Private Sub Command7_Click() '清空NDEF记录
'技术支持:
'网站:
Dim status As Byte '存放返回值
Dim myctrlword As Byte
Dim i As Integer
Dim mypiccserial(0 To 6) As Byte '卡序列号
Dim mypiccseriallen(1) As Byte '卡序列号字节数
Dim picckey(0 To 15) As Byte '需要认证的密码
Dim str As String
Dim strls1 As String
Dim strls2 As String
Dim strlen As Integer '数据字符串的长度
'ctrlword:bit3指定卡，bit4为1函数指定密码为0表示内部密码，bit5操作完后休眠卡,bit6用指定密码写卡，bit7尝试NFC默认密码写卡,如果bit6和bit7都为1，表示先要指定密码写卡，如果不对就用NFC默认密码
'bit2为1写卡后同时将B密码改为newkey指定的密码。
'密码
If (Check1.Value > 0) Then
strls1 = Text1.Text
strlen = Len(strls1)
str = ""
For i = 1 To strlen
strls2 = Mid(strls1, i, 1)
If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblf
str = str + strls2
End If
Next i
strlen = Len(str)
If strlen < 32 Then
MsgBox "密码长度不足"
Text1.SetFocus
Exit Sub
End If
strlen = 0
For i = 1 To 32 Step 2
strls2 = Mid(str, i, 2)
picckey(strlen) = CByte("&h" & strls2)
strlen = strlen + 1
Next i
myctrlword = &H40
Else
myctrlword = &H0
End If
tagbuf_forumtype4_clear
status = forumtype4_write_ndeftag(myctrlword, mypiccserial(0), mypiccseriallen(0), picckey(0))
Select Case status
Case 0:
For i = 0 To (mypiccseriallen(0) - 1)
str = str + Right("0" + Hex(mypiccserial(i)), 2)
Next i
pcdbeep 38
MsgBox "清空NDEF记录成功！卡号：" & str
Case 8:
MsgBox "请将卡放在感应区"
Case 23: '没有动态库
MsgBox "请连上USB 读写器"
Case 57: '卡片不支持功能
MsgBox "卡片不支持Forum_Type4协议，可能不是Forum_Type4_Tag卡"
Case Else
MsgBox "异常：" + CStr(status)
End Select
End Sub
Private Sub Command8_Click() '清空数据缓冲
tagbuf_forumtype4_clear
End Sub
Private Sub Command9_Click() '名片 写入卡片
'技术支持:
'网站:
Dim status As Byte '存放返回值
Dim myctrlword As Byte
Dim i As Integer
Dim mypiccserial(0 To 6) As Byte '卡序列号
Dim mypiccseriallen(1) As Byte '卡序列号字节数
Dim picckey(0 To 15) As Byte '需要认证的密码
Dim str As String
Dim strls1 As String
Dim strls2 As String
Dim strlen As Integer '数据字符串的长度
Dim infostr As String
Dim infostrlen As Long
'名片信息
infostr = "BEGIN:VCARD" & Chr(10)
infostr = infostr & "VERSION:3.0" & Chr(10)
infostr = infostr & "FN:" & Text10.Text & Chr(10)
infostr = infostr & "TEL:" & Text12.Text & Chr(10)
infostr = infostr & "ORG:" & Text13.Text & Chr(10)
infostr = infostr & "ADR:" & Text14.Text & Chr(10)
infostr = infostr & "EMAIL:" & Text15.Text & Chr(10)
infostr = infostr & "URL:" & Text16.Text & Chr(10)
infostr = infostr & "END:VCARD"
infostrlen = LenB(StrConv(infostr, vbFromUnicode))
tagbuf_forumtype4_clear
status = tagbuf_addbusinesscard(infostr, infostrlen)
'可以写入多条记录
If (status > 0) Then
MsgBox "异常：" + CStr(status)
Exit Sub
End If
'密码
If (Check1.Value > 0) Then
strls1 = Text1.Text
strlen = Len(strls1)
str = ""
For i = 1 To strlen
strls2 = Mid(strls1, i, 1)
If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblf
str = str + strls2
End If
Next i
strlen = Len(str)
If strlen < 32 Then
MsgBox "密码长度不足"
Text1.SetFocus
Exit Sub
End If
strlen = 0
For i = 1 To 32 Step 2
strls2 = Mid(str, i, 2)
picckey(strlen) = CByte("&h" & strls2)
strlen = strlen + 1
Next i
myctrlword = &H40
Else
myctrlword = &H0
End If
status = forumtype4_write_ndeftag(myctrlword, mypiccserial(0), mypiccseriallen(0), picckey(0))
Select Case status
Case 0:
For i = 0 To (mypiccseriallen(0) - 1)
str = str + Right("0" + Hex(mypiccserial(i)), 2)
Next i
pcdbeep 38
MsgBox "写卡成功！卡号：" & str
Case 8:
MsgBox "请将卡放在感应区"
Case 23: '没有动态库
MsgBox "请连上USB 读写器"
Case 57: '卡片不支持功能
MsgBox "卡片不支持Forum_Type4协议，可能不是Forum_Type4_Tag卡"
Case Else
MsgBox "异常：" + CStr(status)
End Select
End Sub
Private Sub Form_Load()
Combo1.ListIndex = 0 '无前缀
Combo2.ListIndex = 7 'WPA+WPA2个人
Combo3.ListIndex = 4 '无前缀
Combo4.ListIndex = 3 '微信
End Sub