本示例使用的发卡器https://item.taobao.com/item.htm?fttid615391857885一、解析分享信息获取短链接URIPrivate Sub Text28_LostFocus() Dim shorturl As String Dim pos1 As Long, pos2 As Long shorturl Trim(Text28.Text) shorturl Replace(Trim(shorturl), vbCrLf, ) shorturl Replace(shorturl, vbLf, ) shorturl Replace(shorturl, vbCr, ) shorturl shorturl If Len(shorturl) 5 Then If InStr(shorturl, https://v.douyin.com) 0 Then pos1 InStr(shorturl, https://v.douyin.com) pos2 InStr(pos1, shorturl, ) If pos2 pos1 Then shorturl Mid(shorturl, pos1, pos2 - pos1) End If Combo6.ListIndex 0 ElseIf InStr(shorturl, http://xhslink.com) 0 Then pos1 InStr(shorturl, http://xhslink.com) pos2 InStr(pos1, shorturl, ) If pos2 pos1 Then shorturl Mid(shorturl, pos1, pos2 - pos1) End If Combo6.ListIndex 1 ElseIf InStr(shorturl, https://c6.y.qq.com) 0 Then pos1 InStr(shorturl, https://c6.y.qq.com) pos2 InStr(pos1, shorturl, ) If pos2 pos1 Then shorturl Mid(shorturl, pos1, pos2 - pos1) End If Combo6.ListIndex 2 ElseIf InStr(shorturl, https://qishui.douyin.com) 0 Then pos1 InStr(shorturl, https://qishui.douyin.com) pos2 InStr(pos1, shorturl, ) If pos2 pos1 Then shorturl Mid(shorturl, pos1, pos2 - pos1) End If Combo6.ListIndex 3 ElseIf InStr(shorturl, https://m.kugou.com) 0 Then pos1 InStr(shorturl, https://m.kugou.com) pos2 InStr(pos1, shorturl, ) If pos2 pos1 Then shorturl Mid(shorturl, pos1, pos2 - pos1) End If Combo6.ListIndex 4 ElseIf InStr(shorturl, https://163cn.tv) 0 Then pos1 InStr(shorturl, https://163cn.tv) pos2 InStr(pos1, shorturl, ?() If pos2 pos1 Then shorturl Mid(shorturl, pos1, pos2 - pos1) ElseIf InStr(pos1, shorturl, ) pos1 Then pos2 InStr(pos1, shorturl, ) shorturl Mid(shorturl, pos1, pos2 - pos1) ElseIf InStr(pos1, shorturl, ?) pos1 Then pos2 InStr(pos1, shorturl, ?) shorturl Mid(shorturl, pos1, pos2 - pos1) End If Combo6.ListIndex 5 ElseIf InStr(shorturl, 163) 0 And InStr(shorturl, id) 0 Then pos1 InStr(shorturl, id) 3 pos2 InStr(pos1, shorturl, ) If pos2 pos1 Then Text29.Text Mid(shorturl, pos1, pos2 - pos1) Combo6.ListIndex 5 Exit Sub End If Else MsgBox 暂无法解析您输入的音乐分享链接, vbCritical vbOKOnly, 提示 Exit Sub End If Text29.Text GetMusicID(shorturl) Else Text29.Text End If End Sub二、发送短链接Get请求获取音乐IDPrivate Function GetMusicID(ByVal ShareUrl As String) As String On Error GoTo ErrorHandler Dim http As Object Dim RequestStr As String Dim pos1 As Long, pos2 As Long 创建 WinHttpRequest 对象VB6 最稳定 Set http CreateObject(WinHttp.WinHttpRequest.5.1) 禁止自动跳转手动获取 302 真实地址 http.Option(6) False 关键不自动重定向 发送请求 http.Open GET, ShareUrl, False http.setRequestHeader User-Agent, Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/120.0.0.0 Safari/537.36 http.send 获取 302 跳转后的真实链接 RequestStr http.getResponseHeader(Location) 如果没有跳转直接用当前页面内容 If RequestStr Then RequestStr ShareUrl End If Select Case Combo6.ListIndex Case 0 抖音 If InStr(RequestStr, video/) 0 Then pos1 InStr(RequestStr, video/) 6 pos2 InStr(pos1, RequestStr, /?region) If pos2 pos1 Then GetMusicID Mid(RequestStr, pos1, pos2 - pos1) End If End If Case 1 小红书 If InStr(RequestStr, item/) 0 Then pos1 InStr(RequestStr, item/) 5 pos2 InStr(pos1, RequestStr, ?app_platform) If pos2 pos1 Then GetMusicID Mid(RequestStr, pos1, pos2 - pos1) End If End If Case 2 QQ音乐 If InStr(RequestStr, song/) 0 Then pos1 InStr(RequestStr, song/) 5 pos2 InStr(pos1, RequestStr, .html) If pos2 pos1 Then GetMusicID Mid(RequestStr, pos1, pos2 - pos1) End If ElseIf InStr(RequestStr, songmid) 0 Then pos1 InStr(RequestStr, songmid) 8 pos2 InStr(pos1, RequestStr, type) If pos2 pos1 Then GetMusicID Mid(RequestStr, pos1, pos2 - pos1) End If End If Case 3 汽水音乐 If InStr(RequestStr, track_id) 0 Then pos1 InStr(RequestStr, track_id) 9 pos2 InStr(pos1, RequestStr, ) If pos2 pos1 Then GetMusicID Mid(RequestStr, pos1, pos2 - pos1) End If End If Case 4 酷狗音乐 If InStr(RequestStr, share/) 0 Then pos1 InStr(RequestStr, share/) 6 pos2 InStr(pos1, RequestStr, .html) If pos2 pos1 Then GetMusicID Mid(RequestStr, pos1, pos2 - pos1) End If End If Case Else 网易云音乐 If InStr(RequestStr, song?id) 0 Then pos1 InStr(RequestStr, song?id) 8 pos2 InStr(pos1, RequestStr, ) If pos2 pos1 Then GetMusicID Mid(RequestStr, pos1, pos2 - pos1) End If End If End Select Cleanup: Set http Nothing Exit Function ErrorHandler: GetMusicID Resume Cleanup End Function三、将获取到的音乐ID写入NFC标签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 ntag21xmirrorbuf(0 To 6) As Byte Ntag21x UID或计数器镜像功能配置值缓冲 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 uristr1 As String Dim uristrlen As Long Dim wcount As Integer Dim taginfstr As String CheckCardType languagecodestr en 语言编码英文为en,中文为zh languagecodestrlen 2 titlestr titlestrlen 0 Select Case Combo6.ListIndex Case 0 抖音 uristr snssdk1128://aweme/detail/ Trim(Text29.Text) Case 1 小红书 uristr xhsdiscover://video_feed/ Trim(Text29.Text) Case 2 QQ音乐 uristr qqmusic://qq.com/media/playSonglist?p{song:[{songmid: Trim(Text29.Text) }],action:play} Case 3 汽水音乐 uristr luna://luna.com/playing?track_id Trim(Text29.Text) Case 4 酷狗音乐 uristr kugou://start.weixin?{cmd:303,jsonStr:{title:,url:m.kugou.com/share/song.html?chain Trim(Text29.Text) }} uristr1 kugouurl://start.weixin?{cmd:303,jsonStr:{title:,url:https://m.kugou.com/share/song.html?chain Trim(Text29.Text) }} Case Else 网易云音乐 uristr orpheus://song/ Trim(Text29.Text) /?autoplaytrue End Select taginfstr uristr 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)) taginfstr taginfstr , cardstr tagbuf_forumtype4_clear tagbuf_clear status tagbuf_adduri(languagecodestr, languagecodestrlen, titlestr, titlestrlen, uriheaderindex, uristr, uristrlen) If (status 0) Then dispstr 生成NDEF播放音乐数据 dispriv dispstr, status Exit Sub ElseIf Combo6.ListIndex 2 Then QQ音乐再加入app包名称 Dim packagestr As String Dim packagestrlen As Long packagestr com.tencent.qqmusic packagestrlen LenB(StrConv(packagestr, vbFromUnicode)) status tagbuf_addapp(packagestr, packagestrlen) ElseIf Combo6.ListIndex 4 Then 酷狗音乐再加入苹果记录 uristrlen LenB(StrConv(uristr1, vbFromUnicode)) status tagbuf_adduri(languagecodestr, languagecodestrlen, titlestr, titlestrlen, uriheaderindex, uristr1, uristrlen) End If If CardType 1 Then ForumType2、Ntag2 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 WritDevBufferCSV taginfstr If (Check3.Value 0 And Check2.Value 1) Or (Check3.Value 1 And Check2.Value 0) Then NtagKeyEn If Check1.Value 0 Then Text18_GotFocus ElseIf CardType 2 Then ForumType5、15693 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 WritDevBufferCSV taginfstr 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 If Check1.Value 0 Then Text18_GotFocus ElseIf CardType 3 Then MifareClassIc 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播放音乐 WritDevBufferCSV taginfstr dispriv dispstr, status If Check1.Value 0 Then Text18_GotFocus ElseIf CardType 4 Then ForumType4 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播放音乐 WritDevBufferCSV taginfstr 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 If Check1.Value 0 Then Text18_GotFocus End If