一键写入启动游戏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
相关推荐
金銀銅鐵3 天前
[Python] 模 n 乘法的逆元计算器
python·数学·游戏
金銀銅鐵4 天前
借助 Pygame 探索最大公约数的规律
python·数学·游戏
nujnewnehc8 天前
不会 py, 用 ai 写了个游戏辅助的感受
人工智能·游戏
jump_jump9 天前
为了重玩金庸群侠传，我研究了一下 Ruffle 怎么复活 Flash
游戏·rust·github
XIAOHEZIcode10 天前
Linux系统鼠标偏移常见原因以及修复方案
linux·运维·游戏
Aloys_Code11 天前
逆向一个被遗忘的DVD游戏格式：从DES加密到Rust模拟器
游戏·模拟器·retroarch·复古游戏·native32·sunplus·赤刃·钢铁风暴
金銀銅鐵11 天前
用 Python 实现 Take-Away 游戏
python·游戏
金銀銅鐵12 天前
用 Pygame 实现 15 puzzle
python·数学·游戏
两水先木示14 天前
【Unity3D】小游戏启动优化、发热优化、蒙皮网格优化
游戏
资源分享助手14 天前
杀戮尖塔2下载、Slay the Spire 2中文版、卡牌肉鸽游戏、杀戮尖塔2联机、杀戮尖塔2攻略
游戏
热门推荐
012026年6月AI大模型全景报告：GPT-5.6、Claude Opus 4.8、Gemini 3.5，中美AI三足鼎立谁主沉浮？022026年6月AI行业全景：从百模大战到Agent元年，这30天发生了什么？032026 年 AI 编程工具终极横评：Cursor vs Claude Code vs Copilot vs Windsurf04Trae国际版与国内版深度测评：AI原生IDE的双生花05飞书长连接_事件订阅（接收消息，审批任务状态变更）06Claude Code、Codex、Cursor三分天下：2026年AI编程Agent生态全景剖析07【AI】2026 年具身智能模型和世界模型总结08GitHub 镜像站点092026 AI 编程工具终极实战指南：Cursor vs Claude Code vs Copilot，开发者该怎么选？102026年AI架构实战：彻底解决OpenAI接口超时与封号，Python调用GPT-5.2/Sora2企业级架构详解（附源码+压测报告）