一键写入启动游戏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
相关推荐
林川~0113 小时前
Unity 万能物理检测工具：射线检测 / 范围检测 / 层级过滤 / 编辑器可视化（可直接拿去用）
游戏·unity·c#·射线检测·通用工具
一孤程2 天前
游戏测试专题第七篇：游戏自动化测试实战
游戏·测试
一孤程2 天前
游戏测试专题第八篇：游戏安全测试与反外挂
游戏·测试
河南花仙子科技3 天前
小游戏社交裂变功能的高阶设计思路
大数据·科技·游戏
一孤程3 天前
游戏测试专题第五篇：游戏兼容性测试与多端适配
游戏·测试
狂人开飞机4 天前
23、实战平台跳跃游戏
游戏·游戏引擎·godot
甲维斯4 天前
0代码，0建模，3句话开发一个3D游戏！
前端·游戏·游戏开发
笨鸟先飞的橘猫4 天前
树结构在游戏行业中的应用
学习·游戏
Sylvia33.4 天前
火星数据体育API｜一站式接入足球篮球电竞等18+项目实时数据
java·开发语言·python·websocket·游戏
小小数媒成员4 天前
GPU优化（1）
游戏·unity·游戏引擎
热门推荐
01国内可直接用、免费额度/永久免费的大模型API清单（含 SiliconFlow、火山、阿里、智谱、百度、Kimi、DeepSeek、DMXAPI 等）02蜘蛛磁力 搜索引擎大全，如何使用蜘蛛磁力查找磁力链接03GitHub 镜像站点04人工智能（AI）发展史：详细里程碑05历年考研数学一、数学二、数学三真题试卷及答案PDF06微信历史版本含下载地址（ Windows PC | 安卓 | MAC ）及设置微信不更新072026 国产 AI 大模型横评：DeepSeek、通义千问、Kimi、文心一言、星火、豆包谁更能打？08ZCode 周末送额度活动开启：3 亿 Token 免费领取09数学公理体系大全:第六章 选择公理的等价形式及证明102026 爱知・名古屋亚运会怎么看？直播平台+赛程安排分享