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 BytePrivate 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 tagbuf_forumtype4_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 BytePrivate Declare Function tagbuf_forumtype4_addtext Lib "OUR_MIFARE.dll" (ByVal languagecodestr As String, ByVal languagecodestrlen As Long, ByVal textstr As String, ByVal textstrlen As Long) As BytePrivate Declare Function forumtype4request Lib "OUR_MIFARE.dll" (ByVal ctrlword As Byte, ByRef serial As Byte, ByRef seriallen As Byte) As BytePrivate 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 BytePrivate 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 SubPrivate Sub Command1_Click() '将链接写入卡片'技术支持:
'网站:
Dim status As Byte '存放返回值Dim myctrlword As Byte
Dim i As IntegerDim 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 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_forumtype4_clearstatus = tagbuf_forumtype4_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 < 32 ThenMsgBox "密码长度不足"Text1.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 32 Step 2strls2 = Mid(str, i, 2)picckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next imyctrlword = &H40
Elsemyctrlword = &H0End Ifstatus = forumtype4_write_ndeftag(myctrlword, mypiccserial(0), mypiccseriallen(0), picckey(0))Select Case statusCase 0:For i = 0 To (mypiccseriallen(0) - 1)str = str + Right("0" + Hex(mypiccserial(i)), 2)Next ipcdbeep 38MsgBox "写卡成功！卡号：" & strCase 8:MsgBox "请将卡放在感应区"Case 23: '没有动态库MsgBox "请连上USB 读写器"Case 57: '卡片不支持功能MsgBox "卡片不支持Forum_Type4协议，可能不是Forum_Type4_Tag卡"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 Command12_Click() '将地理位置写入卡片
'技术支持:
'网站:
Dim status As Byte '存放返回值Dim myctrlword As Byte
Dim i As IntegerDim 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 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_forumtype4_clearstatus = tagbuf_forumtype4_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 < 32 ThenMsgBox "密码长度不足"Text1.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 32 Step 2strls2 = Mid(str, i, 2)picckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next imyctrlword = &H40
Elsemyctrlword = &H0End Ifstatus = forumtype4_write_ndeftag(myctrlword, mypiccserial(0), mypiccseriallen(0), picckey(0))Select Case statusCase 0:For i = 0 To (mypiccseriallen(0) - 1)str = str + Right("0" + Hex(mypiccserial(i)), 2)Next ipcdbeep 38MsgBox "写卡成功！卡号：" & strCase 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 Command2_Click() '将纯文本写入卡片'技术支持:
'网站:
Dim status As Byte '存放返回值Dim myctrlword As Byte
Dim i As IntegerDim 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 StringDim strlen As Integer '数据字符串的长度Dim languagecodestr As StringDim languagecodestrlen As LongDim textstr As StringDim textstrlen As LongDim uriheaderindex As Long'语言编码，英文为en,中文为zh
languagecodestr = "en"
languagecodestrlen = 2'文本
textstr = Text5.Text
textstrlen = LenB(StrConv(textstr, vbFromUnicode))tagbuf_forumtype4_clearstatus = tagbuf_forumtype4_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 < 32 ThenMsgBox "密码长度不足"Text1.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 32 Step 2strls2 = Mid(str, i, 2)picckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next imyctrlword = &H40
Elsemyctrlword = &H0End Ifstatus = forumtype4_write_ndeftag(myctrlword, mypiccserial(0), mypiccseriallen(0), picckey(0))Select Case statusCase 0:For i = 0 To (mypiccseriallen(0) - 1)str = str + Right("0" + Hex(mypiccserial(i)), 2)Next ipcdbeep 38MsgBox "写卡成功！卡号：" & strCase 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 Byte
Dim i As IntegerDim 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 statusCase 0, 52: 'Case Is = 0, Is = 52:For i = 0 To (mypiccseriallen(0) - 1)str = str + Right("0" + Hex(mypiccserial(i)), 2)Next ipcdbeep 38MsgBox "寻卡成功！卡号：" & strCase 8:MsgBox "请将卡放在感应区"Case 23: '没有动态库MsgBox "请连上USB 读写器"Case ElseMsgBox "异常：" + CStr(status)End Select
End 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 Command7_Click() '清空NDEF记录'技术支持:
'网站:
Dim status As Byte '存放返回值
Dim myctrlword As Byte
Dim i As IntegerDim 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 StringDim strlen As Integer '数据字符串的长度'ctrlword:bit3指定卡，bit4为1函数指定密码为0表示内部密码，bit5操作完后休眠卡,bit6用指定密码写卡，bit7尝试NFC默认密码写卡,如果bit6和bit7都为1，表示先要指定密码写卡，如果不对就用NFC默认密码
'bit2为1写卡后同时将B密码改为newkey指定的密码。'密码
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 < 32 ThenMsgBox "密码长度不足"Text1.SetFocusExit SubEnd Ifstrlen = 0For i = 1 To 32 Step 2strls2 = Mid(str, i, 2)picckey(strlen) = CByte("&h" & strls2)strlen = strlen + 1Next imyctrlword = &H40
Elsemyctrlword = &H0End Iftagbuf_forumtype4_clearstatus = forumtype4_write_ndeftag(myctrlword, mypiccserial(0), mypiccseriallen(0), picckey(0))Select Case statusCase 0:For i = 0 To (mypiccseriallen(0) - 1)str = str + Right("0" + Hex(mypiccserial(i)), 2)Next ipcdbeep 38MsgBox "清空NDEF记录成功！卡号：" & strCase 8:MsgBox "请将卡放在感应区"Case 23: '没有动态库MsgBox "请连上USB 读写器"Case 57: '卡片不支持功能MsgBox "卡片不支持Forum_Type4协议，可能不是Forum_Type4_Tag卡"Case ElseMsgBox "异常：" + CStr(status)End Select
End SubPrivate Sub Command8_Click() '清空数据缓冲tagbuf_forumtype4_clear
End SubPrivate Sub Form_Load()Combo1.ListIndex = 0 '无前缀
End SubPrivate Sub Label12_Click()End Sub
