给WAV文件加音乐标签工具（适用与win10——win11）

imperialeast

’给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
'============Form  Commnd====================

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