NDEF 全称 NFC data exchange format 即 nfc 数据交换格式，是一种标准化的数据格式，可用于在任何兼容的NFC设备与另一个NFC设备或标签之间交换信息。数据格式由NDEF消息和NDEF记录组成。
NDEF信息可以写到不同类型的NFC芯片中，如Ntag系列芯片标、15693系列芯片、MifareClassic系列芯片、Forum_Type4_Tag标签等，不同类型的芯片NDEF信息的存储方式也略有不同，这就大大增加了NDEF信息写入、读取的难度。
广州荣士电子将各种不同类型的NDEF记录类型的写入、读取方式都函数化，开发人员不需再了解复杂的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 BytePrivate Declare Sub tagbuf_read Lib "OUR_MIFARE.dll" (ByVal revstr As String, ByRef revstrlen As Long, ByRef recordnumber As Long)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
Private Declare Function piccread_ndeftag Lib "OUR_MIFARE.dll" (ByVal ctrlword As Byte, ByRef serial As Byte, ByRef oldkey As Byte) As BytePrivate Sub Combo1_Click()Select Case Combo1.ListIndexCase 0:Label14.Caption = "由于无前缀，请输入完整的地址"Case 1, 2Label14.Caption = "例如：baidu.com"Case ElseLabel14.Caption = ""End Select
End SubPrivate Sub Combo4_Click()Dim packagestr(0 To 14) As Stringpackagestr(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 ThenText23.Text = packagestr(Combo4.ListIndex)End If
End SubPrivate Sub Command1_Click() '将链接写入卡片'技术支持:
'网站:
Dim status As Byte '存放返回值Dim myctrlword As Byte
Dim i As IntegerDim mypiccserial(0 To 3) As Byte '卡序列号Dim oldpicckey(0 To 5) As Byte '需要认证的密码Dim newpicckey(0 To 5) As Byte '需要认证的密码Dim str As String
Dim strls1 As String
Dim strls2 As StringDim strlen As Integer '数据字符串的长度Dim languagecodestr As StringDim languagecodestrlen As LongDim titlestr As StringDim titlestrlen As LongDim uriheaderindex As LongDim uristr As StringDim 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_clearstatus = 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) ThenMsgBox "异常：" + CStr(status)Exit SubEnd If'旧密码
If (Check1.Value > 0) Thenstrls1 = Text1.Textstrlen = Len(strls1)str = ""For i = 1 To strlenstrls2 = Mid(strls1, i, 1)If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblfstr = str + strls2End IfNext istrlen = Len(str)If strlen < 12 ThenMsgBox "密码长度不足"Text1.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 12 Step 2strls2 = Mid(str, i, 2)oldpicckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next i
End If'新密码
If (Check2.Value > 0) Thenstrls1 = Text2.Textstrlen = Len(strls1)str = ""For i = 1 To strlenstrls2 = Mid(strls1, i, 1)If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblfstr = str + strls2End IfNext istrlen = Len(str)If strlen < 12 ThenMsgBox "密码长度不足"Text2.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 12 Step 2strls2 = Mid(str, i, 2)newpicckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next i
End IfIf Check1.Value > 0 Thenmyctrlword = &H80 + &H40 + &H10
Elsemyctrlword = &H80 + &H10
End IfIf Check2.Value > 0 Thenmyctrlword = myctrlword + &H4
End Ifstatus = piccwrite_ndeftag(myctrlword, mypiccserial(0), oldpicckey(0), newpicckey(0))Select Case statusCase 0:pcdbeep 38MsgBox "写卡成功！"Case 8:MsgBox "请将卡放在感应区"Case 23: '没有动态库MsgBox "请连上USB 读写器"Case ElseMsgBox "异常：" + 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 SubPrivate Sub Command10_Click() '蓝牙 写入卡片
'技术支持:
'网站:
Dim status As Byte '存放返回值Dim myctrlword As Byte
Dim i As IntegerDim mypiccserial(0 To 3) As Byte '卡序列号Dim oldpicckey(0 To 5) As Byte '需要认证的密码Dim newpicckey(0 To 5) As Byte '需要认证的密码Dim str As String
Dim strls1 As String
Dim strls2 As StringDim 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 strlenstrls2 = Mid(strls1, i, 1)If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblfstr = str + strls2End IfNext istrlen = Len(str)If strlen < 12 ThenMsgBox "蓝牙MAC地址长度不足"Text1.SetFocusExit Sub
End Ifstrlen = 0
For i = 1 To 12 Step 2strls2 = Mid(str, i, 2)blemac(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next itagbuf_clearstatus = tagbuf_addbluetooth(blenamestr, blenamestrlen, blemac(0))'可以写入多条记录If (status > 0) ThenMsgBox "异常：" + CStr(status)Exit SubEnd If'旧密码
If (Check1.Value > 0) Thenstrls1 = Text1.Textstrlen = Len(strls1)str = ""For i = 1 To strlenstrls2 = Mid(strls1, i, 1)If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblfstr = str + strls2End IfNext istrlen = Len(str)If strlen < 12 ThenMsgBox "密码长度不足"Text1.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 12 Step 2strls2 = Mid(str, i, 2)oldpicckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next i
End If'新密码
If (Check2.Value > 0) Thenstrls1 = Text2.Textstrlen = Len(strls1)str = ""For i = 1 To strlenstrls2 = Mid(strls1, i, 1)If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblfstr = str + strls2End IfNext istrlen = Len(str)If strlen < 12 ThenMsgBox "密码长度不足"Text2.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 12 Step 2strls2 = Mid(str, i, 2)newpicckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next i
End IfIf Check1.Value > 0 Thenmyctrlword = &H80 + &H40 + &H10
Elsemyctrlword = &H80 + &H10
End IfIf Check2.Value > 0 Thenmyctrlword = myctrlword + &H4
End Ifstatus = piccwrite_ndeftag(myctrlword, mypiccserial(0), oldpicckey(0), newpicckey(0))Select Case statusCase 0:pcdbeep 38MsgBox "写卡成功！"Case 8:MsgBox "请将卡放在感应区"Case 23: '没有动态库MsgBox "请连上USB 读写器"Case ElseMsgBox "异常：" + CStr(status)End Select
End SubPrivate Sub Command11_Click() 'WIFI 写入卡片'技术支持:
'网站:
Dim status As Byte '存放返回值Dim myctrlword As Byte
Dim i As IntegerDim mypiccserial(0 To 3) As Byte '卡序列号Dim oldpicckey(0 To 5) As Byte '需要认证的密码Dim newpicckey(0 To 5) As Byte '需要认证的密码Dim str As String
Dim strls1 As String
Dim strls2 As StringDim strlen As Integer '数据字符串的长度Dim ssidstr As String
Dim ssidstrlen As LongDim authtype As Long
Dim crypttype As LongDim 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_clearstatus = tagbuf_addwifi(ssidstr, ssidstrlen, authtype, crypttype, keystr, keystrlen)'可以写入多条记录If (status > 0) ThenMsgBox "异常：" + CStr(status)Exit SubEnd If'旧密码
If (Check1.Value > 0) Thenstrls1 = Text1.Textstrlen = Len(strls1)str = ""For i = 1 To strlenstrls2 = Mid(strls1, i, 1)If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblfstr = str + strls2End IfNext istrlen = Len(str)If strlen < 12 ThenMsgBox "密码长度不足"Text1.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 12 Step 2strls2 = Mid(str, i, 2)oldpicckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next i
End If'新密码
If (Check2.Value > 0) Thenstrls1 = Text2.Textstrlen = Len(strls1)str = ""For i = 1 To strlenstrls2 = Mid(strls1, i, 1)If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblfstr = str + strls2End IfNext istrlen = Len(str)If strlen < 12 ThenMsgBox "密码长度不足"Text2.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 12 Step 2strls2 = Mid(str, i, 2)newpicckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next i
End IfIf Check1.Value > 0 Thenmyctrlword = &H80 + &H40 + &H10
Elsemyctrlword = &H80 + &H10
End IfIf Check2.Value > 0 Thenmyctrlword = myctrlword + &H4
End Ifstatus = piccwrite_ndeftag(myctrlword, mypiccserial(0), oldpicckey(0), newpicckey(0))Select Case statusCase 0:pcdbeep 38MsgBox "写卡成功！"Case 8:MsgBox "请将卡放在感应区"Case 23: '没有动态库MsgBox "请连上USB 读写器"Case ElseMsgBox "异常：" + CStr(status)End Select
End SubPrivate Sub Command12_Click() '将地理位置写入卡片
'技术支持:
'网站:
Dim status As Byte '存放返回值Dim myctrlword As Byte
Dim i As IntegerDim mypiccserial(0 To 3) As Byte '卡序列号Dim oldpicckey(0 To 5) As Byte '需要认证的密码Dim newpicckey(0 To 5) As Byte '需要认证的密码Dim str As String
Dim strls1 As String
Dim strls2 As StringDim strlen As Integer '数据字符串的长度Dim languagecodestr As StringDim languagecodestrlen As LongDim titlestr As StringDim titlestrlen As LongDim uriheaderindex As LongDim uristr As StringDim 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_clearstatus = tagbuf_adduri(languagecodestr, languagecodestrlen, titlestr, titlestrlen, uriheaderindex, uristr, uristrlen)If (status > 0) ThenMsgBox "异常：" + CStr(status)Exit SubEnd If'旧密码
If (Check1.Value > 0) Thenstrls1 = Text1.Textstrlen = Len(strls1)str = ""For i = 1 To strlenstrls2 = Mid(strls1, i, 1)If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblfstr = str + strls2End IfNext istrlen = Len(str)If strlen < 12 ThenMsgBox "密码长度不足"Text1.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 12 Step 2strls2 = Mid(str, i, 2)oldpicckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next i
End If'新密码
If (Check2.Value > 0) Thenstrls1 = Text2.Textstrlen = Len(strls1)str = ""For i = 1 To strlenstrls2 = Mid(strls1, i, 1)If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblfstr = str + strls2End IfNext istrlen = Len(str)If strlen < 12 ThenMsgBox "密码长度不足"Text2.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 12 Step 2strls2 = Mid(str, i, 2)newpicckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next i
End IfIf Check1.Value > 0 Thenmyctrlword = &H80 + &H40 + &H10
Elsemyctrlword = &H80 + &H10
End IfIf Check2.Value > 0 Thenmyctrlword = myctrlword + &H4
End Ifstatus = piccwrite_ndeftag(myctrlword, mypiccserial(0), oldpicckey(0), newpicckey(0))Select Case statusCase 0:pcdbeep 38MsgBox "写卡成功！"Case 8:MsgBox "请将卡放在感应区"Case 23: '没有动态库MsgBox "请连上USB 读写器"Case ElseMsgBox "异常：" + 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 SubPrivate Sub Command13_Click() '读取NFC海报卡中的记录'技术支持:
'网站:
Dim status As Byte '存放返回值Dim myctrlword As Byte
Dim i As IntegerDim mypiccserial(0 To 3) As Byte '卡序列号Dim oldpicckey(0 To 5) As Byte '需要认证的密码Dim ndefstr As String
Dim revstrlen(1) As Long
Dim recordnumber(1) As LongDim str As String
Dim strls1 As String
Dim strls2 As StringDim strlen As Integer '数据字符串的长度'旧密码
If (Check1.Value > 0) Thenstrls1 = Text1.Textstrlen = Len(strls1)str = ""For i = 1 To strlenstrls2 = Mid(strls1, i, 1)If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblfstr = str + strls2End IfNext istrlen = Len(str)If strlen < 12 ThenMsgBox "密码长度不足"Text1.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 12 Step 2strls2 = Mid(str, i, 2)oldpicckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next i
End IfIf Check1.Value > 0 Thenmyctrlword = &H80 + &H40 + &H10
Elsemyctrlword = &H80 + &H10
End Ifstatus = piccread_ndeftag(myctrlword, mypiccserial(0), oldpicckey(0))Select Case statusCase 0:ndefstr = String(2048, 0)tagbuf_read ndefstr, revstrlen(0), recordnumber(0)Text11.Text = ndefstrpcdbeep 38MsgBox "读卡成功！"Case 8:MsgBox "请将卡放在感应区"Case 23: '没有动态库MsgBox "请连上USB 读写器"Case ElseMsgBox "异常：" + CStr(status)End SelectEnd SubPrivate Sub Command14_Click() 'APP应用自启 写入卡片
'技术支持:
'网站:
Dim status As Byte '存放返回值Dim myctrlword As Byte
Dim i As IntegerDim mypiccserial(0 To 3) As Byte '卡序列号Dim oldpicckey(0 To 5) As Byte '需要认证的密码Dim newpicckey(0 To 5) As Byte '需要认证的密码Dim str As String
Dim strls1 As String
Dim strls2 As StringDim strlen As Integer '数据字符串的长度Dim packagestr As String
Dim packagestrlen As Longpackagestr = Text23.Text
packagestrlen = LenB(StrConv(packagestr, vbFromUnicode))tagbuf_clearstatus = tagbuf_addapp(packagestr, packagestrlen)'可以写入多条记录If (status > 0) ThenMsgBox "异常：" + CStr(status)Exit SubEnd If'旧密码
If (Check1.Value > 0) Thenstrls1 = Text1.Textstrlen = Len(strls1)str = ""For i = 1 To strlenstrls2 = Mid(strls1, i, 1)If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblfstr = str + strls2End IfNext istrlen = Len(str)If strlen < 12 ThenMsgBox "密码长度不足"Text1.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 12 Step 2strls2 = Mid(str, i, 2)oldpicckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next i
End If'新密码
If (Check2.Value > 0) Thenstrls1 = Text2.Textstrlen = Len(strls1)str = ""For i = 1 To strlenstrls2 = Mid(strls1, i, 1)If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblfstr = str + strls2End IfNext istrlen = Len(str)If strlen < 12 ThenMsgBox "密码长度不足"Text2.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 12 Step 2strls2 = Mid(str, i, 2)newpicckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next i
End IfIf Check1.Value > 0 Thenmyctrlword = &H80 + &H40 + &H10
Elsemyctrlword = &H80 + &H10
End IfIf Check2.Value > 0 Thenmyctrlword = myctrlword + &H4
End Ifstatus = piccwrite_ndeftag(myctrlword, mypiccserial(0), oldpicckey(0), newpicckey(0))Select Case statusCase 0:pcdbeep 38MsgBox "写卡成功！"Case 8:MsgBox "请将卡放在感应区"Case 23: '没有动态库MsgBox "请连上USB 读写器"Case ElseMsgBox "异常：" + CStr(status)End Select
End SubPrivate Sub Command15_Click() '数据 写入卡片
'技术支持:
'网站:
Dim status As Byte '存放返回值Dim myctrlword As Byte
Dim i As IntegerDim mypiccserial(0 To 3) As Byte '卡序列号Dim oldpicckey(0 To 5) As Byte '需要认证的密码Dim newpicckey(0 To 5) As Byte '需要认证的密码Dim str As String
Dim strls1 As String
Dim strls2 As StringDim strlen As Integer '数据字符串的长度Dim typestr As String
Dim typestrlen As Long
Dim datastr As String
Dim datastrlen As Longtypestr = Text20.Text
typestrlen = LenB(StrConv(typestr, vbFromUnicode))datastr = Text19.Text
datastrlen = LenB(StrConv(datastr, vbFromUnicode))tagbuf_clearstatus = tagbuf_adddata(typestr, typestrlen, datastr, datastrlen)'可以写入多条记录If (status > 0) ThenMsgBox "异常：" + CStr(status)Exit SubEnd If'旧密码
If (Check1.Value > 0) Thenstrls1 = Text1.Textstrlen = Len(strls1)str = ""For i = 1 To strlenstrls2 = Mid(strls1, i, 1)If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblfstr = str + strls2End IfNext istrlen = Len(str)If strlen < 12 ThenMsgBox "密码长度不足"Text1.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 12 Step 2strls2 = Mid(str, i, 2)oldpicckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next i
End If'新密码
If (Check2.Value > 0) Thenstrls1 = Text2.Textstrlen = Len(strls1)str = ""For i = 1 To strlenstrls2 = Mid(strls1, i, 1)If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblfstr = str + strls2End IfNext istrlen = Len(str)If strlen < 12 ThenMsgBox "密码长度不足"Text2.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 12 Step 2strls2 = Mid(str, i, 2)newpicckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next i
End IfIf Check1.Value > 0 Thenmyctrlword = &H80 + &H40 + &H10
Elsemyctrlword = &H80 + &H10
End IfIf Check2.Value > 0 Thenmyctrlword = myctrlword + &H4
End Ifstatus = piccwrite_ndeftag(myctrlword, mypiccserial(0), oldpicckey(0), newpicckey(0))Select Case statusCase 0:pcdbeep 38MsgBox "写卡成功！"Case 8:MsgBox "请将卡放在感应区"Case 23: '没有动态库MsgBox "请连上USB 读写器"Case ElseMsgBox "异常：" + CStr(status)End Select
End SubPrivate Sub Command2_Click() '将纯文本写入卡片'技术支持:
'网站:
Dim status As Byte '存放返回值Dim myctrlword As Byte
Dim i As IntegerDim mypiccserial(0 To 3) As Byte '卡序列号Dim oldpicckey(0 To 5) As Byte '需要认证的密码Dim newpicckey(0 To 5) As Byte '需要认证的密码Dim str As String
Dim strls1 As String
Dim strls2 As StringDim strlen As Integer '数据字符串的长度Dim languagecodestr As StringDim languagecodestrlen As LongDim textstr As StringDim textstrlen As Long'语言编码，英文为en,中文为zh
languagecodestr = "en"
languagecodestrlen = 2'文本
textstr = Text5.Text
textstrlen = LenB(StrConv(textstr, vbFromUnicode))tagbuf_clearstatus = tagbuf_addtext(languagecodestr, languagecodestrlen, textstr, textstrlen)If (status > 0) ThenMsgBox "异常：" + CStr(status)Exit SubEnd If'旧密码
If (Check1.Value > 0) Thenstrls1 = Text1.Textstrlen = Len(strls1)str = ""For i = 1 To strlenstrls2 = Mid(strls1, i, 1)If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblfstr = str + strls2End IfNext istrlen = Len(str)If strlen < 12 ThenMsgBox "密码长度不足"Text1.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 12 Step 2strls2 = Mid(str, i, 2)oldpicckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next i
End If'新密码
If (Check2.Value > 0) Thenstrls1 = Text2.Textstrlen = Len(strls1)str = ""For i = 1 To strlenstrls2 = Mid(strls1, i, 1)If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblfstr = str + strls2End IfNext istrlen = Len(str)If strlen < 12 ThenMsgBox "密码长度不足"Text2.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 12 Step 2strls2 = Mid(str, i, 2)newpicckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next i
End IfIf Check1.Value > 0 Thenmyctrlword = &H80 + &H40 + &H10
Elsemyctrlword = &H80 + &H10
End IfIf Check2.Value > 0 Thenmyctrlword = myctrlword + &H4
End Ifstatus = piccwrite_ndeftag(myctrlword, mypiccserial(0), oldpicckey(0), newpicckey(0))Select Case statusCase 0:pcdbeep 38MsgBox "写卡成功！"Case 8:MsgBox "请将卡放在感应区"Case 23: '没有动态库MsgBox "请连上USB 读写器"Case ElseMsgBox "异常：" + 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 SubPrivate Sub Command3_Click() '清空为出厂卡'技术支持:
'网站:
Dim status As Byte '存放返回值
Dim myctrlword As ByteDim i As IntegerDim mypiccserial(0 To 3) As Byte '卡序列号Dim oldpicckey(0 To 5) As Byte '需要认证的密码Dim str As String
Dim strls1 As String
Dim strls2 As StringDim strlen As Integer '数据字符串的长度'旧密码
If (Check1.Value > 0) Thenstrls1 = Text1.Textstrlen = Len(strls1)str = ""For i = 1 To strlenstrls2 = Mid(strls1, i, 1)If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblfstr = str + strls2End IfNext istrlen = Len(str)If strlen < 12 ThenMsgBox "密码长度不足"Text1.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 12 Step 2strls2 = Mid(str, i, 2)oldpicckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next i
End If'ctrlword:bit3指定卡，bit4为1函数指定密码为0表示内部密码，bit5操作完后休眠卡,bit6用指定密码写卡，bit7尝试NFC默认密码写卡,如果bit6和bit7都为1，表示先用指定密码写卡，如果不对就用NFC默认密码,bit6和bit7都为0时相当于都为1
'bit1为1将卡同时改为出厂时的FF,访问位也改为出厂的卡
If Check1.Value > 0 Thenmyctrlword = &H80 + &H40 + &H10 + &H2
Elsemyctrlword = &H80 + &H10 + &H2
End Ifstatus = piccclear_ndeftag(myctrlword, mypiccserial(0), oldpicckey(0))Select Case statusCase 0:pcdbeep 38MsgBox "清空成出厂卡成功！"Case 8:MsgBox "请将卡放在感应区"Case 23: '没有动态库MsgBox "请连上USB 读写器"Case ElseMsgBox "异常：" + CStr(status)End SelectEnd SubPrivate Sub Command4_Click()
'让设备发出声音
'技术支持:
'网站:pcdbeep 50End SubPrivate Sub Command5_Click()
'读取设备编号，可做为软件加密狗用,也可以根据此编号在公司网站上查询保修期限'技术支持:
'网站:
Dim status As ByteDim devno(0 To 3) As Byte '设备编号status = pcdgetdevicenumber(VarPtr(devno(0)))If status = 0 ThenMsgBox 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 SubPrivate Sub Command6_Click() '电话 写入卡片'技术支持:
'网站:
Dim status As Byte '存放返回值Dim myctrlword As Byte
Dim i As IntegerDim mypiccserial(0 To 3) As Byte '卡序列号Dim oldpicckey(0 To 5) As Byte '需要认证的密码Dim newpicckey(0 To 5) As Byte '需要认证的密码Dim str As String
Dim strls1 As String
Dim strls2 As StringDim strlen As Integer '数据字符串的长度Dim languagecodestr As StringDim languagecodestrlen As LongDim uristr As StringDim uristrlen As Long'语言编码，英文为en,中文为zh
languagecodestr = "en"
languagecodestrlen = 2'链接
uristr = Text9.Text
uristrlen = LenB(StrConv(uristr, vbFromUnicode))tagbuf_clearstatus = tagbuf_adduri(languagecodestr, languagecodestrlen, "", 0, 5, uristr, uristrlen)If (status > 0) ThenMsgBox "异常：" + CStr(status)Exit SubEnd If'旧密码
If (Check1.Value > 0) Thenstrls1 = Text1.Textstrlen = Len(strls1)str = ""For i = 1 To strlenstrls2 = Mid(strls1, i, 1)If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblfstr = str + strls2End IfNext istrlen = Len(str)If strlen < 12 ThenMsgBox "密码长度不足"Text1.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 12 Step 2strls2 = Mid(str, i, 2)oldpicckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next i
End If'新密码
If (Check2.Value > 0) Thenstrls1 = Text2.Textstrlen = Len(strls1)str = ""For i = 1 To strlenstrls2 = Mid(strls1, i, 1)If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblfstr = str + strls2End IfNext istrlen = Len(str)If strlen < 12 ThenMsgBox "密码长度不足"Text2.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 12 Step 2strls2 = Mid(str, i, 2)newpicckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next i
End IfIf Check1.Value > 0 Thenmyctrlword = &H80 + &H40 + &H10
Elsemyctrlword = &H80 + &H10
End IfIf Check2.Value > 0 Thenmyctrlword = myctrlword + &H4
End Ifstatus = piccwrite_ndeftag(myctrlword, mypiccserial(0), oldpicckey(0), newpicckey(0))Select Case statusCase 0:pcdbeep 38MsgBox "写卡成功！"Case 8:MsgBox "请将卡放在感应区"Case 23: '没有动态库MsgBox "请连上USB 读写器"Case ElseMsgBox "异常：" + CStr(status)End SelectEnd SubPrivate Sub Command7_Click() '初始化成NFC智能海报卡'技术支持:
'网站:
Dim status As Byte '存放返回值
Dim myctrlword As Byte
Dim i As IntegerDim mypiccserial(0 To 3) As Byte '卡序列号Dim oldpicckey(0 To 5) As Byte '需要认证的密码Dim newpicckey(0 To 5) As Byte '需要认证的密码Dim str As String
Dim strls1 As String
Dim strls2 As StringDim strlen As Integer '数据字符串的长度'旧密码
If (Check1.Value > 0) Thenstrls1 = Text1.Textstrlen = Len(strls1)str = ""For i = 1 To strlenstrls2 = Mid(strls1, i, 1)If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblfstr = str + strls2End IfNext istrlen = Len(str)If strlen < 12 ThenMsgBox "密码长度不足"Text1.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 12 Step 2strls2 = Mid(str, i, 2)oldpicckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next i
End If'新密码
If (Check2.Value > 0) Thenstrls1 = Text2.Textstrlen = Len(strls1)str = ""For i = 1 To strlenstrls2 = Mid(strls1, i, 1)If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblfstr = str + strls2End IfNext istrlen = Len(str)If strlen < 12 ThenMsgBox "密码长度不足"Text2.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 12 Step 2strls2 = Mid(str, i, 2)newpicckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next i
End If'ctrlword:bit3指定卡，bit4为1函数指定密码为0表示内部密码，bit5操作完后休眠卡,bit6用指定密码写卡，bit7尝试NFC默认密码写卡,如果bit6和bit7都为1，表示先要指定密码写卡，如果不对就用NFC默认密码
'bit2为1写卡后同时将B密码改为newkey指定的密码。tagbuf_clearIf Check1.Value > 0 Thenmyctrlword = &H80 + &H40 + &H10
Elsemyctrlword = &H80 + &H10
End IfIf Check2.Value > 0 Thenmyctrlword = myctrlword + &H4
End Ifstatus = piccwrite_ndeftag(myctrlword, mypiccserial(0), oldpicckey(0), newpicckey(0))Select Case statusCase 0:pcdbeep 38MsgBox "初始化卡成功！"Case 8:MsgBox "请将卡放在感应区"Case 23: '没有动态库MsgBox "请连上USB 读写器"Case ElseMsgBox "异常：" + CStr(status)End Select
End SubPrivate Sub Command8_Click() '清空数据缓冲tagbuf_clear
End SubPrivate Sub Command9_Click() '名片 写入卡片'技术支持:
'网站:
Dim status As Byte '存放返回值Dim myctrlword As Byte
Dim i As IntegerDim mypiccserial(0 To 3) As Byte '卡序列号Dim oldpicckey(0 To 5) As Byte '需要认证的密码Dim newpicckey(0 To 5) As Byte '需要认证的密码Dim str As String
Dim strls1 As String
Dim strls2 As StringDim strlen As Integer '数据字符串的长度Dim infostr As StringDim 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_clearstatus = tagbuf_addbusinesscard(infostr, infostrlen)
'可以写入多条记录If (status > 0) ThenMsgBox "异常：" + CStr(status)Exit SubEnd If'旧密码
If (Check1.Value > 0) Thenstrls1 = Text1.Textstrlen = Len(strls1)str = ""For i = 1 To strlenstrls2 = Mid(strls1, i, 1)If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblfstr = str + strls2End IfNext istrlen = Len(str)If strlen < 12 ThenMsgBox "密码长度不足"Text1.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 12 Step 2strls2 = Mid(str, i, 2)oldpicckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next i
End If'新密码
If (Check2.Value > 0) Thenstrls1 = Text2.Textstrlen = Len(strls1)str = ""For i = 1 To strlenstrls2 = Mid(strls1, i, 1)If (strls2 <> " ") And (strls2 <> vbCr) And (strls2 <> vbCrLf) And (strls2 <> vbLf) Then 'vbcr,vbcrlf,vblfstr = str + strls2End IfNext istrlen = Len(str)If strlen < 12 ThenMsgBox "密码长度不足"Text2.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 12 Step 2strls2 = Mid(str, i, 2)newpicckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next i
End IfIf Check1.Value > 0 Thenmyctrlword = &H80 + &H40 + &H10
Elsemyctrlword = &H80 + &H10
End IfIf Check2.Value > 0 Thenmyctrlword = myctrlword + &H4
End Ifstatus = piccwrite_ndeftag(myctrlword, mypiccserial(0), oldpicckey(0), newpicckey(0))Select Case statusCase 0:pcdbeep 38MsgBox "写卡成功！"Case 8:MsgBox "请将卡放在感应区"Case 23: '没有动态库MsgBox "请连上USB 读写器"Case ElseMsgBox "异常：" + CStr(status)End Select
End SubPrivate Sub Form_Load()Combo1.ListIndex = 0 '无前缀Combo2.ListIndex = 7 'WPA+WPA2个人Combo3.ListIndex = 4 '无前缀Combo4.ListIndex = 3 '微信
End Sub
