一键写入启动游戏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
相关推荐
国际学术会议-杨老师20 小时前
2026年游戏美学、动画生成与色彩科学国际会议（GEAAC 2026）
游戏·动画·色彩科学
qizayaoshuap21 小时前
# [特殊字符] 猜数字 — 鸿蒙ArkTS游戏逻辑与交互反馈系统设计
游戏·华为·harmonyos
梅雅达编程笔记1 天前
编程启蒙｜Scratch 转 Python 系列第10天：问答闯关游戏实战（AI题库管理+随机出题实战）
人工智能·python·游戏·青少年编程
weixin_439857542 天前
借助AI制作的贪吃蛇游戏（单HTML文件）
游戏·html·ai编程
快乐星空Maker2 天前
C++【生存游戏】开发：荒岛往事 第三期
开发语言·c++·游戏·编程语言
AA陈超2 天前
006 T03 — 蓝图操作指南
c++·游戏·架构·ue5·github·虚幻引擎
cd_949217212 天前
Unity游戏角色资产怎么快速制作？用V2Fun跑通生成、绑定和导入测试
游戏·unity·游戏引擎
tokenKe3 天前
Epic Games 发布下一代版本控制系统 Lore：被 HN 干到 1000+ 分的“游戏版 Git“
git·游戏
可爱系程序猿3 天前
d3d11.dll 缺失或加载失败怎么排查？Direct3D 11、显卡驱动和游戏文件完整性记录
程序人生·游戏·电脑
中国搜索直付通3 天前
避开直付通选型暗礁：二级商户的合规生存与背景甄别
java·大数据·开发语言·人工智能·游戏
热门推荐
012026年7月AI圈大地震：GPT-5.6被政府限制、Claude入驻Slack、Anthropic自研芯片02GitHub 镜像站点03如何新建文件夹？ 电脑新建文件夹的4种方法04AI科技热点日报 | 2026年07月01日05幻兽帕鲁 - 服务器管理员权限与 GM 命令完全指南06国内可直接用、免费额度/永久免费的大模型API清单（含 SiliconFlow、火山、阿里、智谱、百度、Kimi、DeepSeek、DMXAPI 等）07【AI前线观察】2026年国产开源大模型全面横评：从 DeepSeek V4 到 Kimi K3，谁才是开发者的最优选择？08AI 编程 IDE 全景解析 2026：Agent 全面接管开发链路092026年AI技术突破与产业落地全景：从GPT-5到多模态智能体的新纪元102026 国产 AI 大模型横评：DeepSeek、通义千问、Kimi、文心一言、星火、豆包谁更能打？