Распознавание речи

Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
Private Sub Command1_Click()
    GoogleSpeak "Это пример озвучки Google"
    GoogleSpeak "Голос очень напоминает Акапелкину Аленку"
End Sub
 
Private Sub Form_Load()
   InitCommonControls
End Sub
 
Function Text2UTF8(text As String) As String
    Dim i, c, utfc, b1, b2, b3
    
    For i = 1 To Len(text)
        c = ToLong(AscW(Mid(text, i, 1)))
  
        If c < 128 Then
            utfc = "%" & Hex(c)
        ElseIf c < 2048 Then
            b1 = c Mod &H40
            b2 = (c - b1) / &H40
            utfc = "%" & Hex(&HC0 + b2) & "%" & Hex(&H80 + b1)
        ElseIf c < 65536 And (c < 55296 Or c > 57343) Then
            b1 = c Mod &H40
            b2 = ((c - b1) / &H40) Mod &H40
            b3 = (c - b1 - (&H40 * b2)) / &H1000
            utfc = "%" & Chr(&HE0 + b3) & "%" & Chr(&H80 + b2) & "%" & Chr(&H80 + b1)
        Else
            ' UTF-16
            utfc = "%" & Chr(&HEF) & "%" & Chr(&HBF) & "%" & Chr(&HBD)
        End If
 
        Text2UTF8 = Text2UTF8 + utfc
    Next
End Function
 
Function ToLong(intVal)
    If intVal < 0 Then
        ToLong = CLng(intVal) + &H10000
    Else
        ToLong = CLng(intVal)
    End If
End Function
 
Private Sub GoogleSpeak(text As String)
Dim FileLength As Long
Dim sTempPath As String, ML As String
 
sTempPath = App.Path & "\TempGVoice.MP3"
    If URLDownloadToFile(0&, "http://translate.google.ru/translate_tts?ie=UTF-8&q=" & Text2UTF8(text) & "&tl=ru&total=1&idx=0&textlen=" & Len(text), sTempPath, 0&, 0&) = 0 Then
        If mciSendString("open " & Chr$(34) & sTempPath & Chr$(34) & " type MpegVideo" & " alias myfile", 0&, 0&, 0&) = 0 Then
            ML = String(30, 0)
            Call mciSendString("status myfile length ", ML, 30, 0&)
            FileLength = Val(ML)
            If FileLength Then
              If mciSendString("set myFile speed " & 1050, "", 0, 0) = 0 Then 
                If mciSendString("play myFile", 0&, 0&, 0&) = 0 Then
                    Do While mciSendString("status myfile position ", ML, 30, 0&) = 0
                        If Val(ML) = FileLength Then Exit Do
                        If bDoEvents Then DoEvents
                    Loop
                End If
              End If
            End If
            Call mciSendString("close myfile", 0&, 0&, 0&)
        End If
        Kill sTempPath
    End If
End Sub

Private Sub Command1_Click() 
Dim arr() As Byte 
Open App.Path & "\tmp.flac" For Binary Access Read As #1 
ReDim arr(LOF(1)) As Byte 
Get #1, , arr 
    Inet1.Execute "https://www.google.com/speech-api/v1/recognize?xjerr=1&client=chromium&lang=ru-RU", "POST", StrConv(arr(), vbUnicode), "Content-Type: audio/x-flac; rate=8000" 
Close #1 
End Sub 
 
Private Sub Inet1_StateChanged(ByVal State As Integer) 
If State = icResponseCompleted Then 
      Dim vtData As Variant 
      Dim strData As String: strData = "" 
      Dim bDone As Boolean: bDone = False 
 
      ' Первый чанк 
      vtData = Inet1.GetChunk(1024, icString) 
      DoEvents 
      Do While Not bDone 
         strData = strData & vtData 
         DoEvents 
         ' Следующий чанк 
         vtData = Inet1.GetChunk(1024, icString) 
         If Len(vtData) = 0 Then 
            bDone = True 
         End If 
      Loop 
      Debug.Print DecodeUTF8(parseAnswer(strData)) 
End If 
End Sub 
 
Function parseAnswer(a As String) As String 
Dim sPos As Long 
    sPos = InStr(1, a, Chr$(34) & "utterance" & Chr$(34) & ":" & Chr$(34), vbTextCompare) 
    parseAnswer = Mid(a, 13 + sPos, InStrRev(a, Chr$(34) & "," & Chr$(34) & "confidence" & Chr$(34)) - (13 + sPos)) 
End Function 
 
Function DecodeUTF8(s As String) As String 
    Dim i As Long, c As Long, n As Long, b1 As Integer, b2 As Integer, b3 As Integer 
 
    i = 1 
    Do While i <= Len(s) 
        c = Asc(Mid(s, i, 1)) 
        If (c And &HC0) = &HC0 Then 
            n = 1 
            Do While i + n <= Len(s) 
                If (Asc(Mid(s, i + n, 1)) And &HC0) <> &H80 Then 
                    Exit Do 
                End If 
                n = n + 1 
            Loop 
            If n = 2 And ((c And &HE0) = &HC0) Then 
                b1 = Asc(Mid(s, i + 1, 1)) And &H3F 
                b2 = c And &H1F 
                c = b1 + b2 * &H40 
            ElseIf n = 3 And ((c And &HF0) = &HE0) Then 
                b1 = Asc(Mid(s, i + 2, 1)) And &H3F 
                b2 = Asc(Mid(s, i + 1, 1)) And &H3F 
                b3 = c And &HF 
                c = b3 * &H1000 + b2 * &H40 + b1 
            Else 
                c = &HFFFD 
            End If 
            s = Left(s, i - 1) + ChrW(c) + Mid(s, i + n) 
        ElseIf (c And &HC0) = &H80 Then 
            s = Left(s, i - 1) + ChrW(&HFFFD) + Mid(s, i + 1) 
        End If 
        i = i + 1 
    Loop 
    DecodeUTF8 = s 
End Function