一、发送分享的短链接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
Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
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
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
ElseIf InStr(RequestStr, "note/") > 0 Then
pos1 = InStr(RequestStr, "note/") + 5
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标签
Private Sub Timer16_Timer()
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 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
uriheaderindex = 0
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
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
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播放音乐"
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播放音乐"
End If
End Sub
|
