Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByValuReturnLength As Long, ByVal hwndCallback As Long) As Long
Public Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Public Sub GetandDwnLd()
Dim URL As String, Str As String, StrPath As String
Str = "Good Day"
q = "q=" & UTF8_Encode(Str)
tl = "tl=ar" ' english
textlen = "textlen=" & Len(Str) 'Strings count
tk = "tk=" & 469412.102682 '<<<<<< tk specific number for ""Good Day" >>>>>> so if change words need their tk
URL = "https://translate.google.com/translate_tts?ie=UTF-8&" & q & "&" & tl & "&total=1&idx=0&" & textlen & "&client=tw-ob" ' Media web
StrPath = Environ("USERPROFILE") & "\Desktop\translate_tts.mp3"
DwnLdTTS2MP3 URL, StrPath 'download media File
'then Play Soun
PlayMP3 (StrPath)
End Sub
Private Function ConvertToGet(val As String)
val = Replace(val, " ", "+")
val = Replace(val, vbNewLine, "+")
val = Replace(val, "(", "%28")
val = Replace(val, ")", "%29")
ConvertToGet = val
End Function
Private Function Clean(val As String)
val = Replace(val, """, """")
val = Replace(val, "%2C", ",")
val = Replace(val, "'", "'")
Clean = val
End Function
Function DwnLdTTS2MP3(URL, strHDLocation)
Set objXMLHTTP = CreateObject("Microsoft.XMLHTTP")
objXMLHTTP.Open "GET", URL, False
objXMLHTTP.Send
Set objStream = CreateObject("Adodb.Stream")
objStream.Type = 1
objStream.Open
objStream.Write objXMLHTTP.responseBody
If Dir(strHDLocation) <> "" Then
StopMP3
Kill strHDLocation
Else
End If
objStream.savetofile strHDLocation, 2
objStream.Close
Set objStream = Nothing
Set objXMLHTTP = Nothing
End Function
Public Sub PlayMP3(ByVal Mp3 As String)
Dim Tmp As Long, Tmp2 As String
Tmp2 = ShortName(Mp3)
Tmp = mciSendString("close MP3_Device", vbNullString, 0&, 0&)
Tmp = mciSendString("open " & Tmp2 & " type MPEGVideo alias MP3_Device", vbNullString, 0&, 0&)
Tmp = mciSendString("play Mp3_Device", vbNullString, 0&, 0&)
End Sub
Public Sub StopMP3()
Dim Tmp As Long
Tmp = mciSendString("close MP3_Device", vbNullString, 0&, 0&)
End Sub
Private Function ShortName(ByVal Fichier As String) As String
Dim Tmp As String * 255, Tmp2 As Byte
Tmp2 = GetShortPathName(Fichier, Tmp, Len(Tmp))
If Tmp2 > 0 Then
ShortName = Left(Tmp, Tmp2)
End If
End Function
Public Function UTF8_Encode(ByVal strIn As String) As String
'Returns a URI string representing the Hexadecimal UTF-8 representation of strIn.
'Modified from code on this page: http://www.nonhostile.com/howto-convert-byte-array-utf8-string-vb6.asp
'Now handles Unicode surrogate pairs.
'
'There's a bit of an issue with how to handle control characters (code points < &H20). As the code
'is currently written line feeds (LF) and tabs are stripped and carriage returns (CR) are replaced
'with spaces. This works well for the Speak function. Leaving in the CRs causes them to be returned,
'as XML. The XML then gets spoken. This is not ideal for the Translate function. Stripping the CRs
'obviously hurts the original formating. This is just a demo, so I've left this unresolved.
'4/17/2013 Greg Zjaba
Dim lngPos As Long
Dim lngUSV As Long
Dim strUTF8 As String
strIn = Trim(strIn)
For lngPos = 1 To Len(strIn)
lngUSV = MakeUSV(Mid$(strIn, lngPos, 2))
If lngUSV < &H10 And lngUSV <> &HA And lngUSV <> &H9 Then
'Single digit code points. Need to add 0 after %.
'IMPORTANT NOTE: Also stripping LF and Tab
If lngUSV <> &HD Then 'CR
strUTF8 = strUTF8 & "%0" & Hex(AscW(Mid$(strIn, lngPos, 1)))
Else
strUTF8 = strUTF8 & "%20" 'Replace CR with space.
End If
ElseIf lngUSV > &H1F And lngUSV < &H80 Then
'US-ASCII - Basic Latin
strUTF8 = strUTF8 & "%" & Hex(AscW(Mid$(strIn, lngPos, 1)))
ElseIf lngUSV > &H7F And lngUSV < &H800 Then
'Basic Multilingual Plane
strUTF8 = strUTF8 & "%" & Hex((lngUSV \ &H40) Or &HC0)
strUTF8 = strUTF8 & "%" & Hex((lngUSV And &H3F) Or &H80)
ElseIf lngUSV > &H7FF And lngUSV < &H10000 Then
'Basic Multilingual Plane
strUTF8 = strUTF8 & "%" & Hex(((lngUSV \ &H1000) And &HF) Or &HE0)
strUTF8 = strUTF8 & "%" & Hex(((lngUSV \ &H40) And &H3F) Or &H80)
strUTF8 = strUTF8 & "%" & Hex((lngUSV And &H3F) Or &H80)
ElseIf lngUSV > &HFFFF& And lngUSV < &H2A700 Then
'Surrogate pairs - Supplementary Multilingual Plane.
strUTF8 = strUTF8 & "%" & Hex(((lngUSV \ &H40000) And &H7) Or &HF0)
strUTF8 = strUTF8 & "%" & Hex(((lngUSV \ &H1000&) And &H3F) Or &H80)
strUTF8 = strUTF8 & "%" & Hex(((lngUSV \ &H40) And &H3F) Or &H80)
strUTF8 = strUTF8 & "%" & Hex((lngUSV And &H3F) Or &H80)
End If
If IsHighSurrogate(AscW(Mid$(strIn, lngPos, 1))) Then
lngPos = lngPos + 1
End If
Next
UTF8_Encode = strUTF8
End Function
Public Function MakeUSV(strCharacter As String) As Long
' Makes Unicode USV value for one character.
' USV is returned as a decimal value and as a Long.
' Handles surrogate pairs.
' 4/17/2013 GZ
Dim lngHiSurr As Long 'Value of high surrogate.
Dim lngLowSurr As Long 'Value of low surrogate.
'Testing for length of 1 or 2 character. If a single character is represented
'by a surrogate pair Len() will report it's length as 2.
If LenB(strCharacter & vbNullString) <> 0 And Len(strCharacter) <= 2 Then
If IsSurrogatePair(strCharacter) Then
lngLowSurr = CLng("&H" & Hex$(AscW(Mid$(strCharacter, 2, 1))))
lngHiSurr = CLng("&H" & Hex$(AscW(Left$(strCharacter, 1))))
'From "The Unicode Standard, Version 6.0", Chapter 3, Section 7 "Surrogates".
MakeUSV = (lngHiSurr - CLng("&HD800")) * CLng("&H400") + _
(lngLowSurr - CLng("&HDC00")) + CLng("&H10000")
Else
MakeUSV = CLng("&H" & Hex$(AscW(strCharacter)))
End If
End If
End Function
Private Function IsSurrogatePair(txtCharacter As String) As Boolean
' Tests if a character is represented by a Unicode surrogate pair.
' Takes a single Unicode character as argument and returnes true or false.
' 4/17/2013 GZ
Dim lngHiSurr As Long
' NOTE: Len returns 2 for a single character if it is a surrogate pair.
If LenB(txtCharacter & vbNullString) <> 0 And Len(txtCharacter) <= 2 Then
lngHiSurr = CLng("&H" & Hex$(AscW(Mid$(txtCharacter, 1, 1))))
If Len(txtCharacter) = 2 Then
If lngHiSurr >= &HD800& And lngHiSurr <= &HDBFF& Then
IsSurrogatePair = True
Else
IsSurrogatePair = False
End If
Else
IsSurrogatePair = False
End If
End If
End Function
Public Function IsHighSurrogate(intCodePoint As Integer) As Boolean
'Returns true if code point is a Unicode high surrogate.
'4/17/2013 GZ
Const cintHighSurrLB As Integer = &HD800 'Lower bound
Const cintHighSurrUB As Integer = &HDBFF 'Upper bound
If intCodePoint >= cintHighSurrLB And intCodePoint <= cintHighSurrUB Then
IsHighSurrogate = True
Else
IsHighSurrogate = False
End If
End Function
