一键写入启动游戏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 小时前
Unity基础（四）向量相关
游戏·unity·游戏引擎
阿阳微客10 小时前
网易Buff游戏搬砖，长期可做！
笔记·学习·游戏
Kurisu57510 小时前
探灵直播2026最新官方正版免费下载 一键转存 永久更新 （看到速转存 资源随时走丢）
游戏·游戏引擎·游戏程序·动画·关卡设计
STDD11 小时前
Abiotic Factor多人生存建筑游戏《非生物因素》 专用服务器搭建教程
服务器·数据库·游戏
开开心心就好12 小时前
带OCR识别的电子发票打印工具
运维·javascript·科技·游戏·青少年编程·ocr·powerpoint
经济元宇宙15 小时前
HOPE星火燎原不是希望工程，也不是游戏项目：项目名称与定位澄清
游戏
2601_9503160615 小时前
XBOX360 KINECT体感游戏合集109个
游戏
伽蓝_游戏1 天前
第二章：深入 Unity 资源导入管线 (Asset Import Pipeline)
游戏·unity·c#·游戏引擎·游戏程序
资源分享助手1 天前
星砂岛游戏下载及完整攻略汇总（5职业养成 / 家园布局 / 全地块与成就 / 载具 / 赚钱）
游戏
热门推荐
01GitHub 镜像站点02Codex 接入 DeepSeek API 完整配置文档03CC-Switch & Claude 基于 Linux 服务器安装使用指南04【踩坑记录 | 第一篇】微软商店无法使用时，如何手动安装 OpenAI Codex？附`.msix`文件系统错误解决方法05裂开！ChatGPT 居然开始要手机号验证，附详细解决方法06几个好用的ip纯净度检测网站07装上就回不去了：CodeGraph 让 AI 编程效率飙升 92%，它到底做了什么？08用了半年 OpenRouter，我换到了 Ofox.ai — 两个 AI API 聚合平台的真实对比09【AI】2026 年具身智能模型和世界模型总结10codex app每次打开重连5次Reconnecting问题解决