端午节快乐！送TTS发音代码，求意见！

bcrun 2013-06-12 11:20:35

加精

?speak("端午节快乐！")

Option Explicit

Public Function ExtractFileName(ByVal strText As String) As String

    Dim iPos As Integer

    iPos = InStrRev(strText, "\")

    ExtractFileName = VBA.Mid$(strText, iPos + 1)

        

End Function



'---------------------------------------------------------------------------------------

' 过程名    : Speak

' 时间      : 2013/6/9

' 作者      : 杨过.网狐.cn(csdn bcrun)

' 功能      : 调用Microsoft Speech读出一段文字（中英文不限）

' 参数      : strText 要朗读的文本,返回值true为成功

' 说明      : 因为暂时还不知道更好的选择合适中文语音库的办法，这里采用了strShortVoiceId参数和查找特殊字符串的办法

' 备注      : 星辰设计室VB一群:283362041,星辰学园BASIC辅导群:289219875

' TTS语音包下载： http://g.iciba.com/dictdown/tts.html

'---------------------------------------------------------------------------------------



Public Function Speak(ByVal strText As String, Optional ByVal strShortVoiceId As String = "MS-Lili-2052-20-DSK") As Boolean

    'Dim objVoice As SpeechLib.SpVoice, colVoice As ISpeechObjectTokens

    Dim objVoice As Object, colVoice As Object

    Dim strSlice As String, cnVoice As Long

    Dim i As Integer

    On Error GoTo Speak_Error

    

    Speak = False

    'Set objVoice = New SpeechLib.SpVoice

    Set objVoice = CreateObject("SAPI.SpVoice")

    Set colVoice = objVoice.GetVoices()                                         '获得语音引擎集合

    cnVoice = colVoice.Count

    objVoice.Volume = 100                                                       '设置音量，0到100，数字越大音量越大

    objVoice.Rate = 1

    '    Set objVoice.Voice = colVoice.Item(cnVoice - 1)

    Dim oVoiceItem As Object, sTokenId As String

    For i = 0 To colVoice.Count - 1

        Set oVoiceItem = colVoice.Item(i)

        '下面是取得形如这样的字符串的最后面一部分：HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Speech\Voices\Tokens\MS-Anna-1033-20-DSK



        sTokenId = ExtractFileName(oVoiceItem.Id)

        If (StrComp(sTokenId, strShortVoiceId) = 0) Then

            Set objVoice.Voice = oVoiceItem

            Exit For

        

        Else

            If (InStr(1, sTokenId, "2052") > 0) _

                Or (InStr(1, sTokenId, "chinese", VbCompareMethod.vbTextCompare) > 0) Then

                Set objVoice.Voice = oVoiceItem

                Exit For

                

            End If

        End If

    Next i

    If (objVoice.Voice Is Nothing) Then Exit Function

    Debug.Print objVoice.Rate

    Dim lTime1 As Long, lTime2 As Long

    'lTime1 = GetTickCount

    'strText = "Welcome to use Kingsoft Powerword"

    Call objVoice.Speak(strText)                                                ', SVSFlagsAsync

    'lTime2 = GetTickCount

    'Debug.Print "Time used: " & (lTime2 - lTime1)

    Speak = True

    

    On Error GoTo 0

    Exit Function

    

Speak_Error:

    

    'MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Speak of Module mdlCommon"

End Function