给WAV文件加音乐标签工具（适用与win10——win11）
本帖最后由 imperialeast 于 2026-7-24 20:24 编辑’给WAV文件加音乐标签工具，部分代码
Option Explicit
' Unicode(UTF16) -> MultiByte(UTF8) API
Private Declare Function WideCharToMultiByte Lib "kernel32.dll" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cbMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cbMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function PathFileExistsW Lib "shlwapi.dll" (ByVal lpathfile As Long) As Boolean
' 常量定义
Private Const WC_NO_BEST_FIT_CHARS As Long = &H400
Private Const CP_UTF8 As Long = 65001
Dim lpWav As String
' 输入：VB6原生字符串(UTF16)
' 输出：UTF8编码的Byte数组
Public Function UnicodeToUTF8(ByVal strUnicode As String) As Byte()
Dim lngStrLen As Long
Dim lngBufSize As Long
Dim abytUTF8() As Byte
' 源字符串长度（字符数）
lngStrLen = Len(strUnicode)
If lngStrLen = 0 Then
ReDim UnicodeToUTF8(-1) ' 返回空数组
Exit Function
End If
' 第一步：获取需要的UTF8缓冲区大小
lngBufSize = WideCharToMultiByte( _
CP_UTF8, WC_NO_BEST_FIT_CHARS, _
StrPtr(strUnicode), lngStrLen, _
0, 0, 0, 0)
If lngBufSize <= 0 Then
ReDim UnicodeToUTF8(-1)
Exit Function
End If
' 分配字节数组
ReDim abytUTF8(1 To lngBufSize)
' 第二步：真正转换到字节数组
Call WideCharToMultiByte( _
CP_UTF8, WC_NO_BEST_FIT_CHARS, _
StrPtr(strUnicode), lngStrLen, _
VarPtr(abytUTF8(1)), lngBufSize, _
0, 0)
UnicodeToUTF8 = abytUTF8
End Function
Public Function UnicodeToUTF8_BOM(ByVal s As String) As Byte()
Dim raw() As Byte
Dim out() As Byte
Dim I As Long, rawLen As Long
raw = UnicodeToUTF8(s)
' 空判断
If Not Not raw Then
rawLen = UBound(raw)
Else
ReDim UnicodeToUTF8_BOM(-1)
Exit Function
End If
' BOM 3字节 + raw全部字节
ReDim out(1 To 3 + rawLen)
out(1) = &HEF
out(2) = &HBB
out(3) = &HBF
' 逐字节拷贝
For I = 1 To rawLen
out(3 + I) = raw(I)
Next I
UnicodeToUTF8_BOM = out
End Function
Public Sub SaveAsUTF8(ByVal sText As String, ByVal sFilePath As String)
Dim bUTF8() As Byte
Dim fNum As Integer
bUTF8 = UnicodeToUTF8(sText)
fNum = FreeFile
Open sFilePath For Binary As #fNum
Put #fNum, , bUTF8
Close #fNum
End Sub
Public Function BytesToHex(bArr() As Byte) As String
Dim I As Long
Dim sOut As String
For I = LBound(bArr) To UBound(bArr)
sOut = sOut & Right("00" & Hex(bArr(I)), 2) & " "
Next
BytesToHex = Trim(sOut)
End Function
'============FormCommnd====================
Private Sub CD_Click()
Dim lW As String, LstD() As Byte, Dt() As String, LstStr As String, lD As String
On Error GoTo Err_x
lpWav = GetFilePaths(Form1.hWnd, "打开WAVE文件", "WAV文件|*.WAV|", Explorer窗口, App.Path, Chr(0))
lpWav = Left(lpWav, InStrRev(lpWav, Chr(0)) - 1)
T.Text = ""
GetHeadInfoMsg lpWav, LstD, lW, lD
'Dat = wH.ChunkID & "|" & wH.ChunkSize & "|" & wH.Format & "|" & _
wH.SubChunk1ID & "|" & wH.SubChunk1Size & "|" & _
wH.AudioFormat & "|" & wH.NumChannels & "|" & wH.BitsPerSaple & "|" & wH.BlockAlign & "|" & wH.SapleRate & "|" & wH.ByteRate & "|" & _
wH.SubChunk2ID & "|" & wH.SubChunk2Size
'//MsgBox UBound(LstD)
Dt = Split(lW, "|")
If UBound(Dt) >= 12 Then
LstStr = "文件类型:" & Dt(0) & vbCrLf & "文件大小(字节):" & Dt(1) & vbCrLf & "文件格式:" & Dt(2) & vbCrLf & "Fmt标示:" & Dt(3) & vbCrLf & _
"数据备注是(>16)否(16):" & Dt(4) & vbCrLf & "音频编码方式(Pcm=1):" & Dt(5) & vbCrLf & "声道:" & Dt(6) & vbCrLf & "采样位数:" & Dt(7) & vbCrLf & _
"采样字节数:" & Dt(8) & vbCrLf & "采样频率:" & Dt(9) & vbCrLf & "文件码率(kbps):" & (Val(Dt(10)) * 8 \ 1000) & vbCrLf & "架构方式:" & Dt(11) & vbCrLf & _
"LIST/DATA长度(字节):" & Dt(12) & vbCrLf
If UCase(Dt(11)) = "DATA" Then
LstStr = LstStr & "时间(秒):" & CLng(Dt(12)) / ((CLng(Dt(9)) * Val(Dt(7)) * Val(Dt(6))) / 8)
Else
Dim St() As String
St = Split(lD, "|")
If UBound(St) > 0 Then LstStr = LstStr & lD & vbCrLf & "时间(秒):" & Val(St(1)) / ((CLng(Dt(9)) * Val(Dt(7)) * Val(Dt(6))) / 8)
End If
End If
'LIST结构信息
Dim Dat() As Byte
'ReDim Dat(UBound(LstD) - 4) As Byte
GetWantData LstD, Dat, 4, UBound(LstD) - 4
LstStr = LstStr & vbCrLf & vbCrLf & "LIST架构信息>>" & vbCrLf & "INFO" & vbCrLf & GetWavListKey(Dat)
T.Text = Replace(LstStr, Chr(0), "") & vbCrLf & "文件路径:" & lpWav
' End If
Exit Sub
Err_x:
T.Text = LstStr & vbCrLf & "文件路径:" & lpWav
End Sub
Public Function GetXFontSize(ByVal XF As Form, ByVal THeight As Long) As Long
Dim I As Long, X(1 To 32) As Long
For I = 1 To 32
XF.ScaleMode = 3
XF.Font.Size = I
If XF.TextHeight("H") = THeight Then
GetXFontSize = I
End If
Next
If GetXFontSize = 0 Then
For I = 1 To 32
XF.ScaleMode = 3
XF.Font.Size = I
If XF.TextHeight("H") > THeight And I > 1 Then
X(I) = XF.TextHeight("H")
If X(I - 1) < THeight Then
GetXFontSize = IIf(X(I) - THeight < THeight - X(I - 1), I, I - 1)
End If
Exit For
End If
Next
End If
End Function
Private Sub CmdI_Click()
Dim LDI(2) As LSTDATAINFO, Ls(2) As Variant
LDI(0).ID = "ICRD"
LDI(0).Size = 26
Ls(0) = UnicodeToUTF8(Year(Now) & "-" & Format(Month(Now), "00") & "-" & Format(Day(Now), "00") & "T" & Format(Hour(Now), "00") & ":" & Format(Minute(Now), "00") & ":" & Format(Second(Now), "00") & "+08:00" & Chr(0))
LDI(1).ID = "INAM"
LDI(1).Size = 6
Ls(1) = UnicodeToUTF8("XiaYU" & Chr(0))
LDI(2).ID = "ISFT"
LDI(2).Size = 13
Ls(2) = UnicodeToUTF8("Lavf60.4.100 " & Chr(0))
Dim lpOut As String
lpOut = Left(lpWav, InStrRev(lpWav, ".") - 1) & "_list.wav"
CreateListWaveFile lpWav, lpOut, LDI, Ls
End Sub
Private Sub Command1_Click()
Dim LDI(4) As LSTDATAINFO, Ls(4) As Variant
If IT(1).Text = "标题" Or IT(1).Text = "" Or IT(0).Text = "艺术家" Or IT(0).Text = "" Or IT(2).Text = "专辑" Or IT(2).Text = "" Then Exit Sub
If CB(0).Text = "中日英文字" Then
Ls(0) = UnicodeToUTF8(IT(0).Text & Chr(0))
LDI(0).Size = Val(UBound(UnicodeToUTF8(IT(0).Text & Chr(0))))
Else
Ls(0) = UnicodeToUTF8_BOM(IT(0).Text & Chr(0))
LDI(0).Size = Val(UBound(UnicodeToUTF8_BOM(IT(0).Text & Chr(0))))
End If
If CB(1).Text = "中日英文字" Then
Ls(1) = UnicodeToUTF8(IT(1).Text & Chr(0))
LDI(1).Size = Val(UBound(UnicodeToUTF8(IT(1).Text & Chr(0))))
Else
Ls(1) = UnicodeToUTF8_BOM(IT(1).Text & Chr(0))
LDI(1).Size = Val(UBound(UnicodeToUTF8_BOM(IT(1).Text & Chr(0))))
End If
If CB(2).Text = "中日英文字" Then
Ls(2) = UnicodeToUTF8(IT(2).Text & Chr(0))
LDI(2).Size = Val(UBound(UnicodeToUTF8(IT(2).Text & Chr(0))))
Else
Ls(2) = UnicodeToUTF8_BOM(IT(2).Text & Chr(0))
LDI(2).Size = Val(UBound(UnicodeToUTF8_BOM(IT(2).Text & Chr(0))))
End If
If CB(3).Text = "中日英文字" Then
Ls(3) = UnicodeToUTF8(IT(3).Text & Chr(0))
LDI(3).Size = Val(UBound(UnicodeToUTF8(IT(3).Text & Chr(0))))
Else
Ls(3) = UnicodeToUTF8_BOM(IT(3).Text & Chr(0))
LDI(3).Size = Val(UBound(UnicodeToUTF8_BOM(IT(3).Text & Chr(0))))
End If
LDI(0).ID = "IART"
LDI(1).ID = "INAM"
LDI(2).ID = "IPRD"
LDI(3).ID = "IGNR"
LDI(4).ID = "ISFT" '"IGNR"
LDI(4).Size = 13
Ls(4) = UnicodeToUTF8("Lavf60.4.100" & Chr(0)) 'StrConv(IT(3).Text, vbUnicode)
Dim lpOut As String
lpOut = Left(lpWav, InStrRev(lpWav, ".") - 1) & "_list.wav"
CreateListWaveFile lpWav, lpOut, LDI, Ls
End Sub
Private Sub Command2_Click()
Dim lpOut As String
lpOut = Left(lpWav, InStrRev(lpWav, ".") - 1) & "_nolist.wav"
CreateNoListWaveFile lpWav, lpOut
End Sub
Private Sub Form_Load()
Dim I As Byte
For I = 0 To 3
CB(I).AddItem "中日英文字"
CB(I).AddItem "其他文字"
CB(I).Text = "中日英文字"
Next
End Sub
'Judge ID rule
Private Function GetRuleID(ByVal ID As String) As Boolean
Dim I As Integer, StrX As String, Str3 As String
For I = 1 To 4
StrX = Mid(ID, I, 1)
If I <= 3 Then
If Asc(StrX) < 65 Or Asc(StrX) > 122 Then
GetRuleID = False: Exit For
Else
GetRuleID = True
End If
Else
Str3 = Left(ID, 3)
If (Asc(StrX) < 65 Or Asc(StrX) > 122) Then
If UCase(Str3) = "FMT" And Asc(StrX) = 32 Then
GetRuleID = True
Else
GetRuleID = False: Exit For
End If
Else
GetRuleID = True
End If
End If
Next
End Function
'GET LIST INFO
Private Function GetWavListKey(Dat() As Byte) As String
Dim wBt() As Byte, LDI As LSTDATAINFO, StepX As Integer, TmpStr As String, ID As String
On Error GoTo Err_INF
Do Until StepX >= UBound(Dat)
GetWantData Dat, wBt, StepX, 8
RtlMoveMemory LDI, wBt(0), 8
Erase wBt
ID = LDI.ID
If GetRuleID(ID) = False Then
StepX = StepX + 1
GetWantData Dat, wBt, StepX, 8
RtlMoveMemory LDI, wBt(0), 8
Erase wBt
Else
TmpStr = TmpStr & LDI.ID & "="
TmpStr = Replace(TmpStr, Chr(0), "")
StepX = StepX + 8
GetWantData Dat, wBt, StepX, Val(LDI.Size)
TmpStr = TmpStr & Utf8ToStr(wBt, LDI.Size) & vbCrLf
Erase wBt
StepX = StepX + Val(LDI.Size)
If StepX = UBound(Dat) Then Exit Do
End If
Loop
GetWavListKey = TmpStr
Exit Function
Err_INF:
GetWavListKey = ""
End Function
'--- UTF-8 Byte数组 → VB6 Unicode String ---
Private Function Utf8ToStr(b() As Byte, ByVal Length As Long) As String
Dim Ws As String, Rtn As Long
If Length <= 0 Then Exit Function
Ws = Space$(Length)
' MultiByteToWideChar CP_UTF8=65001
Rtn = MultiByteToWideChar(65001, 0, VarPtr(b(0)), Length, StrPtr(Ws), Length)
Utf8ToStr = Left(Ws, Rtn)
End Function
页:
[1]