自制考研单词朗读音频

Option Explicit
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, src As Any, ByVal Length As Long)
Private Declare Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
 
Private Const WAVE_CHANNELS As Integer = 1
Private Const WAVE_SAMPLES As Long = 11025
Private Const WAVE_BITS As Integer = 8
 
Private Type RIFF_HEADER
    szRiffID As String * 4
    dwRiffSize As Long
    szRiffFormat As String * 4
End Type
 
Private Type RIFF_BLOCK_HEADER
    szBlockId As String * 4
    dwBlockSize As Long
End Type
 
Private Type WAVE_FORMAT
    wFormatTag As Integer
    wChannels As Integer
    dwSamplesPerSec As Long
    dwAvgBytesPerSec As Long
    wBlockAlign As Integer
    wBitsPerSample As Integer
End Type
 
Dim OutputPath As String
Dim VoicePath As String
Dim PauseTime As Integer
 
Function PageProc(ByVal PageNum As Integer) As Boolean
    PageProc = False
    Dim coll As New Collection
    Dim xml
    Set xml = CreateObject("Microsoft.XMLDOM")
    xml.loadXML ThisDocument.GoTo(wdGoToPage, , , PageNum).GoTo(wdGoToBookmark, , , "\page").xml
    Dim node
    For Each node In xml.SelectNodes("//w:tr/w:tc[0]")
        coll.Add node.Text
    Next
    Dim voice() As Byte
    ReDim voice(WAVE_BITS / 8 * WAVE_CHANNELS * WAVE_SAMPLES * PauseTime * coll.Count() - 1)
    FillMemory voice(0), UBound(voice) + 1, 128
    Dim i As Integer
    For i = 0 To coll.Count() - 1
        Dim b() As Byte
        Dim word As String
        Dim path As String
        word = coll.Item(i + 1)
        path = VoicePath & Left(word, 1) & "\" & word & ".wav"
        If GetWaveData(path, b) Then
            CopyMemory voice(WAVE_BITS / 8 * WAVE_CHANNELS * WAVE_SAMPLES * PauseTime * i), b(0), UBound(b) + 1
        Else
            If MsgBox("无法找到语音：" & word & "，是否继续导出？", vbExclamation + vbYesNo) = vbNo Then Exit Function
        End If
    Next
    SaveWaveData OutputPath & Format(PageNum, "00") & ".wav", voice
    PageProc = True
End Function
 
Function GetWaveData(ByVal path As String, b() As Byte) As Boolean
    GetWaveData = False
    If Len(Dir(path)) = 0 Then Exit Function
    Open path For Binary As 1
    Dim riff As RIFF_HEADER
    Get 1, , riff
    If riff.szRiffID = "RIFF" And riff.szRiffFormat = "WAVE" Then
        Dim block As RIFF_BLOCK_HEADER
        Do While Seek(1) - 1 < 8 + riff.dwRiffSize
            Get 1, , block
            If block.szBlockId = "fmt " Then
                Dim fmt As WAVE_FORMAT
                Get 1, , fmt
                If fmt.wChannels = WAVE_CHANNELS And fmt.dwSamplesPerSec = WAVE_SAMPLES And fmt.wBitsPerSample = WAVE_BITS Then
                    Seek 1, Seek(1) + block.dwBlockSize - LenB(fmt)
                Else
                    Exit Do
                End If
            End If
            If block.szBlockId = "data" Then
                ReDim b(block.dwBlockSize - 1)
                Get 1, , b
                GetWaveData = True
                Exit Do
            End If
        Loop
    End If
    Close 1
End Function
 
Function SaveWaveData(ByVal path As String, b() As Byte) As Boolean
    SaveWaveData = False
    Open path For Binary As 1
    Dim riff As RIFF_HEADER
    riff.szRiffID = "RIFF"
    riff.dwRiffSize = 0
    riff.szRiffFormat = "WAVE"
    Put 1, , riff
    Dim block As RIFF_BLOCK_HEADER
    block.szBlockId = "fmt "
    block.dwBlockSize = 0
    Dim fmt As WAVE_FORMAT

    block.dwBlockSize = LenB(fmt)
    Put 1, , block
    fmt.wFormatTag = 1
    fmt.wChannels = WAVE_CHANNELS
    fmt.dwSamplesPerSec = WAVE_SAMPLES
    fmt.dwAvgBytesPerSec = WAVE_SAMPLES * WAVE_BITS / 8
    fmt.wBlockAlign = WAVE_CHANNELS * WAVE_BITS / 8
    fmt.wBitsPerSample = WAVE_BITS
    Put 1, , fmt
    block.szBlockId = "data"
    block.dwBlockSize = UBound(b) + 1
    Put 1, , block
    Put 1, , b
    riff.dwRiffSize = Seek(1) - 1 - 8
    Seek 1, 1
    Put 1, , riff
    Close 1
    SaveWaveData = True
End Function
 
Private Sub cmdStart_Click()
    VoicePath = txtVoicePath.Text
    PauseTime = txtPauseTime.Text
    OutputPath = ThisDocument.path & "\语音\"
    If Len(Dir(OutputPath)) = 0 Then MkDir OutputPath
    Dim page As Integer
    For page = txtPageStart.Text To txtPageEnd.Text
        Me.Caption = "正在导出第" & page & "页"
        DoEvents
        If PageProc(page) = False Then Exit For
    Next
End Sub
 
Private Sub UserForm_Initialize()
    txtPageEnd.Text = Selection.Information(wdNumberOfPagesInDocument)
End Sub