企业官网建设流程全解析

本示例使用的发卡器：https://item.taobao.com/item.htm?ft=t&id=615391857885

一、解析分享信息获取短链接URI

Private 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请求获取音乐ID

Private 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) & "/?autoplay=true" 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