一键写入启动游戏NDEF复合记录NFC标签vb6源码

津津有味道2026-05-21 13:21

本示例使用的发卡器：https://item.taobao.com/item.htm?spm=a21dvs.23580594.0.0.4fee2c1b0Cm7Vv&ft=t&id=615391857885

vbscript 复制代码 
Dim dispstr As String
Dim status As Byte
Dim afi As Byte
Dim myctrlword As Byte

Dim mypiccserial(0 To 7) As Byte
Dim mypicckey(0 To 15) As Byte
Dim mypiccseriallen(1) As Byte
Dim dataArray() As String

Dim wcount As Integer

Dim packagestr As String
Dim packagestrlen As Long
Dim status0, status1 As Integer

packagestr = Trim(Text27.Text)
packagestr = Replace(Trim(packagestr), vbCrLf, "")
packagestr = Replace(packagestr, vbLf, "")
packagestr = Replace(packagestr, vbCr, "")
packagestrlen = LenB(StrConv(packagestr, vbFromUnicode))

If packagestrlen > 0 Then
    dataArray = Split(packagestr, ";")
    If UBound(dataArray) = 1 Then
        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
            
        languagecodestr = "en"      '语言编码，英文为en,中文为zh
        languagecodestrlen = 2
           
        titlestr = ""     '标题为空
              
        uristr = dataArray(0)
        
        If InStr(uristr, "http://www.") = 1 Then
            uriheaderindex = 1
            uristr = Replace(uristr, "http://www.", "")
        ElseIf InStr(uristr, "https://www.") = 1 Then
            uriheaderindex = 2
            uristr = Replace(uristr, "https://www.", "")
        ElseIf InStr(uristr, "http://") = 1 Then
            uriheaderindex = 3
            uristr = Replace(uristr, "http://", "")
        ElseIf InStr(uristr, "https://") = 1 Then
            uriheaderindex = 4
            uristr = Replace(uristr, "https://", "")
        ElseIf InStr(uristr, "tel:") = 1 Then
            uriheaderindex = 5
            uristr = Replace(uristr, "tel:", "")
        ElseIf InStr(uristr, "mailto:") = 1 Then
            uriheaderindex = 6
            uristr = Replace(uristr, "mailto:", "")
        ElseIf InStr(uristr, "ftp://anonymous:anonymous@") = 1 Then
            uriheaderindex = 7
            uristr = Replace(uristr, "ftp://anonymous:anonymous@", "")
        ElseIf InStr(uristr, "ftp://ftp.") = 1 Then
            uriheaderindex = 8
            uristr = Replace(uristr, "ftp://ftp.", "")
        ElseIf InStr(uristr, "ftps://") = 1 Then
            uriheaderindex = 9
            uristr = Replace(uristr, "ftps://", "")
        ElseIf InStr(uristr, "sftp://") = 1 Then
            uriheaderindex = 10
            uristr = Replace(uristr, "sftp://", "")
        ElseIf InStr(uristr, "smb://") = 1 Then
            uriheaderindex = 11
            uristr = Replace(uristr, "smb://", "")
        ElseIf InStr(uristr, "nfs://") = 1 Then
            uriheaderindex = 12
            uristr = Replace(uristr, "nfs://", "")
        ElseIf InStr(uristr, "ftp://") = 1 Then
            uriheaderindex = 13
            uristr = Replace(uristr, "ftp://", "")
        ElseIf InStr(uristr, "dav://") = 1 Then
            uriheaderindex = 14
            uristr = Replace(uristr, "dav://", "")
        ElseIf InStr(uristr, "news:") = 1 Then
            uriheaderindex = 15
            uristr = Replace(uristr, "news:", "")
        ElseIf InStr(uristr, "telnet://") = 1 Then
            uriheaderindex = 16
            uristr = Replace(uristr, "telnet://", "")
        ElseIf InStr(uristr, "imap:") = 1 Then
            uriheaderindex = 17
            uristr = Replace(uristr, "imap:", "")
        ElseIf InStr(uristr, "rtsp://") = 1 Then
            uriheaderindex = 18
            uristr = Replace(uristr, "rtsp://", "")
        ElseIf InStr(uristr, "urn:") = 1 Then
            uriheaderindex = 19
            uristr = Replace(uristr, "urn:", "")
        ElseIf InStr(uristr, "pop:") = 1 Then
            uriheaderindex = 20
            uristr = Replace(uristr, "pop:", "")
        ElseIf InStr(uristr, "sip:") = 1 Then
            uriheaderindex = 21
            uristr = Replace(uristr, "sip:", "")
        ElseIf InStr(uristr, "sips:") = 1 Then
            uriheaderindex = 22
            uristr = Replace(uristr, "sips:", "")
        ElseIf InStr(uristr, "tftp:") = 1 Then
            uriheaderindex = 23
            uristr = Replace(uristr, "tftp:", "")
        ElseIf InStr(uristr, "btspp://") = 1 Then
            uriheaderindex = 24
            uristr = Replace(uristr, "btspp://", "")
        ElseIf InStr(uristr, "btl2cap://") = 1 Then
            uriheaderindex = 25
            uristr = Replace(uristr, "btl2cap://", "")
        ElseIf InStr(uristr, "btgoep://") = 1 Then
            uriheaderindex = 26
            uristr = Replace(uristr, "btgoep://", "")
        ElseIf InStr(uristr, "tcpobex://") = 1 Then
            uriheaderindex = 27
            uristr = Replace(uristr, "tcpobex://", "")
        ElseIf InStr(uristr, "irdaobex://") = 1 Then
            uriheaderindex = 28
            uristr = Replace(uristr, "irdaobex://", "")
        ElseIf InStr(uristr, "file://") = 1 Then
            uriheaderindex = 29
            uristr = Replace(uristr, "file://", "")
        ElseIf InStr(uristr, "urn:epc:id:") = 1 Then
            uriheaderindex = 30
            uristr = Replace(uristr, "urn:epc:id:", "")
        ElseIf InStr(uristr, "urn:epc:tag:") = 1 Then
            uriheaderindex = 31
            uristr = Replace(uristr, "urn:epc:tag:", "")
        ElseIf InStr(uristr, "urn:epc:pat:") = 1 Then
            uriheaderindex = 32
            uristr = Replace(uristr, "urn:epc:pat:", "")
        ElseIf InStr(uristr, "urn:epc:raw:") = 1 Then
            uriheaderindex = 33
            uristr = Replace(uristr, "urn:epc:raw:", "")
        ElseIf InStr(uristr, "urn:epc:") = 1 Then
            uriheaderindex = 34
            uristr = Replace(uristr, "urn:epc:", "")
        ElseIf InStr(uristr, "urn:nfc:") = 1 Then
            uriheaderindex = 35
            uristr = Replace(uristr, "urn:nfc:", "")
        Else
            uriheaderindex = 0
        End If
        uristrlen = LenB(StrConv(uristr, vbFromUnicode))
                    
        packagestr = dataArray(1)
        packagestrlen = LenB(StrConv(packagestr, vbFromUnicode))
        
    End If
End If
    
CheckCardType

If CardType = 1 Then    'ForumType2、Ntag2
    tagbuf_forumtype4_clear
    
    If uristrlen > 0 Then
        status0 = tagbuf_adduri(languagecodestr, languagecodestrlen, titlestr, titlestrlen, uriheaderindex, uristr, uristrlen)
    Else
        status0 = -1
        ListAddItem "启动游戏的URI链接未正确输入！"
        Exit Sub
    End If
    
    If (packagestrlen > 0) Then
        status1 = tagbuf_addapp(packagestr, packagestrlen)
    Else
        status1 = -1
        ListAddItem "启动游戏的APP包名未正确输入！"
        Exit Sub
    End If
            
    status = status0 + status1
    If (status = 0) Then
        If Check3.Value > 0 Then myctrlword = &H10 Else myctrlword = 0
        Do While wcount < 3     '如果写入失败重写二次
            status = forumtype2_write_ndeftag(myctrlword, mypiccserial(0), oldpicckey(0))
            If status = 0 Then wcount = 3 Else wcount = wcount + 1
        Loop
        dispstr = "NFC_Forum_Type2Uid：" + cardstr + "，写入NDEF启动游戏"
        dispriv dispstr, status
        
        If (Check3.Value > 0 And Check2.Value < 1) Or (Check3.Value < 1 And Check2.Value > 0) Then NtagKeyEn
    Else
        dispstr = "NFC_Forum_Type2Uid：" + cardstr + "，生成NDEF启动游戏数据"
        dispriv dispstr, status
    End If
    
ElseIf CardType = 2 Then    'ForumType5、15693
    tagbuf_forumtype4_clear
    
    If uristrlen > 0 Then
        status0 = tagbuf_adduri(languagecodestr, languagecodestrlen, titlestr, titlestrlen, uriheaderindex, uristr, uristrlen)
    Else
        status0 = -1
        ListAddItem "启动游戏的URI链接未正确输入！"
        Exit Sub
    End If
    
    If (packagestrlen > 0) Then
        status1 = tagbuf_addapp(packagestr, packagestrlen)
    Else
        status1 = -1
        ListAddItem "启动游戏的APP包名未正确输入！"
        Exit Sub
    End If
            
    status = status0 + status1
    If (status = 0) Then
        myctrlword = 0
        afi = 0
        Do While wcount < 3     '如果写入失败重写二次
            status = forumtype5_write_ndeftag(myctrlword, afi, mypiccserial(0))
            If status = 0 Then wcount = 3 Else wcount = wcount + 1
        Loop
        dispstr = "NFC_Forum_Type5Uid：" + cardstr + "，写入NDEF启动游戏"
        dispriv dispstr, status
        
        If Check2.Value > 0 And status = 0 Then
            status = iso15693lockblock(0, 1, VarPtr(mypiccserial(0)))  '15693卡锁定块数据后只能读取不可再修改，为防止卡片锁死，请谨慎锁定
            dispstr = "NFC_Forum_Type5Uid：" & cardstr & " 锁保护标签数据"
            dispNtagKeyEnStatu dispstr, status
        End If
    Else
        dispstr = "NFC_Forum_Type5Uid：" + cardstr + "，生成NDEF启动游戏数据"
        dispriv dispstr, status
    End If
    
ElseIf CardType = 3 Then    'MifareClassIc
    tagbuf_clear
    
    If uristrlen > 0 Then
        status0 = tagbuf_adduri(languagecodestr, languagecodestrlen, titlestr, titlestrlen, uriheaderindex, uristr, uristrlen)
    Else
        status0 = -1
        ListAddItem "启动游戏的URI链接未正确输入！"
        Exit Sub
    End If
    
    If (packagestrlen > 0) Then
        status1 = tagbuf_addapp(packagestr, packagestrlen)
    Else
        status1 = -1
        ListAddItem "启动游戏的APP包名未正确输入！"
        Exit Sub
    End If
            
    status = status0 + status1
    If (status = 0) Then
        If Check3.Value > 0 Then myctrlword = &H80 + &H40 + &H10 + &H2 Else myctrlword = &H80 + &H10 + &H2  'MifareClass卡是否已经加有保护密码
        If Check2.Value > 0 Then myctrlword = myctrlword + &H4  '写入NDEF数据后 并加上保护密码
        Do While wcount < 3     '如果写入失败重写二次
            status = piccwrite_ndeftag(myctrlword, mypiccserial(0), oldpicckey(0), newpicckey(0))
            If status = 0 Then wcount = 3 Else wcount = wcount + 1
        Loop
        dispstr = "MifareClassUid：" + cardstr + "，写入NDEF启动游戏"
        dispriv dispstr, status
    Else
        dispstr = "MifareClassUid：" + cardstr + "，生成NDEF启动游戏数据"
        dispriv dispstr, status
    End If
    
ElseIf CardType = 4 Then    'ForumType4
    tagbuf_forumtype4_clear
    If uristrlen > 0 Then
        status0 = tagbuf_adduri(languagecodestr, languagecodestrlen, titlestr, titlestrlen, uriheaderindex, uristr, uristrlen)
    Else
        status0 = -1
        ListAddItem "启动游戏的URI链接未正确输入！"
        Exit Sub
    End If
    
    If (packagestrlen > 0) Then
        status1 = tagbuf_addapp(packagestr, packagestrlen)
    Else
        status1 = -1
        ListAddItem "启动游戏的APP包名未正确输入！"
        Exit Sub
    End If
            
    status = status0 + status1
    If (status = 0) Then
        If Check3.Value > 0 Then myctrlword = &H40 Else myctrlword = 0
        Do While wcount < 3     '如果写入失败重写二次
            status = forumtype4_write_ndeftag(myctrlword, mypiccserial(0), mypiccseriallen(0), mypicckey(0))
            If status = 0 Then wcount = 3 Else wcount = wcount + 1
        Loop
        dispstr = "NFC_Forum_Type4Uid：" + cardstr + "，写入NDEF启动游戏"
        dispriv dispstr, status
        
        If status = 0 Then
            If (Check3.Value > 0 And Check2.Value < 1) Or (Check3.Value < 1 And Check2.Value > 0) Then Ntag424Config
        End If
    Else
        dispstr = "NFC_Forum_Type4Uid：" + cardstr + "，生成NDEF启动游戏数据"
        dispriv dispstr, status
    End If
End If
相关推荐
漫友也是程序猿8 小时前
ddraw.dll异常排查：旧游戏图形接口、兼容性模式和DirectX组件检查
程序人生·游戏·电脑
远程软件小助理12 小时前
ToDesk节点繁忙、向日葵免费试用受限，还有什么免费好用的远程软件推荐？
经验分享·游戏·远程工作
德迅--文琪13 小时前
游戏盾筑牢网络游戏防攻击安全防线
安全·游戏
Rauser Mack15 小时前
不懂编程，但是vibe coding一个扫雷游戏
人工智能·python·游戏·html·prompt
小雨下雨的雨19 小时前
数独算法与求解器鸿蒙PC Electron框架完成深度解析
javascript·人工智能·算法·游戏·华为·electron·鸿蒙系统
Swift社区19 小时前
鸿蒙游戏自动测试：AI 驱动的测试方案实战
人工智能·游戏·harmonyos
jinxindeep1 天前
CVPR26最佳论文提名：NitroGen，面向通用游戏智能体的 视觉-动作基础模型
人工智能·游戏
海兰1 天前
【水浒传：第二篇】AI江湖 —项目详细设计指南（一）
jvm·人工智能·游戏
会Tk矩阵群控的小木1 天前
安卓群控系统对于游戏工作室实战教程
android·运维·游戏·adb·开源软件·个人开发
wjql22 天前
归环艾丽卡是谁 归环艾丽卡角色介绍
游戏
热门推荐
01《置身钉内》原文-可播放阅读02GitHub 镜像站点03【AI】2026 年具身智能模型和世界模型总结04Codex 下载安装指南：Windows 和 macOS 官方版下载052026 AI 编程工具终极实战指南：Cursor vs Claude Code vs Copilot，开发者该怎么选？062026 年 AI 编程工具终极横评：Cursor vs Claude Code vs Copilot vs Windsurf07【踩坑记录 | 第一篇】微软商店无法使用时，如何手动安装 OpenAI Codex？附`.msix`文件系统错误解决方法08CC-Switch 下载、安装与使用配置指南【2026.5.29】09AI科技热点日报 | 2026年6月1日10CC-Switch & Claude 基于 Linux 服务器安装使用指南