'==============================================================
' GOOGLE SPEECH
'==============================================================
Option Explicit
'//////////////////////////////////////////////////////////////
Public Const INVALID_HANDLE_VALUE = -1
Public Const ERROR_SHARING_VIOLATION = 32
Public Const OPEN_ALWAYS = 4
Public Const FILE_SHARE_READ = &H1
Public Const GENERIC_READ = &H80000000
Public Const GENERIC_WRITE = &H40000000
Public Const GENERIC_EXECUTE = &H20000000
Public Const GENERIC_ALL = &H10000000
'//////////////////////////////////////////////////////////////
#If VBA7 Then
Public Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Public Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function GetLastError Lib "kernel32" () As Long
Private Declare PtrSafe Function CreateFileW Lib "kernel32" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As LongPtr) As LongPtr
Private Declare PtrSafe 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 PtrSafe Function mciGetErrorString Lib "winmm.dll" Alias "mciGetErrorStringA" (ByVal dwError As Long, ByVal lpstrBuffer As String, ByVal uLength As Long) As Long
Private Declare PtrSafe Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameW" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Private Declare PtrSafe 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 PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function CreateFileW Lib "kernel32" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
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 mciGetErrorString Lib "winmm.dll" Alias "mciGetErrorStringA" (ByVal dwError As Long, ByVal lpstrBuffer As String, ByVal uLength As Long) As Long
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameW" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer 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
#End If
'//////////////////////////////////////////////////////////////
#If Win64 Then
Private Pri_TimerID As LongPtr
#Else
Private Pri_TimerID As Long
#End If
'//////////////////////////////////////////////////////////////
Private Type PlayerPlaying
File As String
Index As Integer
list As Variant
Volume As Long
Speed As Double
End Type
'//////////////////////////////////////////////////////////////
Public Const Reg_Section = "Settings"
'//////////////////////////////////////////////////////////////
Public Const ROOT_NAME = "GSpeechXL"
Public Const ROOT_FILE = ROOT_NAME & ".xlam"
Public Const ROOT_FILE_SV = ROOT_NAME & "_sv.xlam"
'//////////////////////////////////////////////////////////////
Public Const LimitLen = 180
Public Const parameter = "/safe"
'//////////////////////////////////////////////////////////////
' SHORTCUT KEY
Public Const SK_SPEECH_ONLY = "^+c"
Public Const SK_SPEECH_TRANSLATE = "^+a"
Public Const SK_SETTINGS = "^+%s"
'//////////////////////////////////////////////////////////////
Public cApp As CAppEvents
Public APP_MAIN As Object
Public APP_ As Object
Private PNP As PlayerPlaying
Private DoTime As Date
Private Pri_Text As String
Private Pri_LangSpeakDefault As String
Private Pri_LangTranslate As String
Private Pri_Translate As Boolean
'///////////////////|
' __ _____ _ ® |
' \ \ / / _ | / \ |
' \ \ /| _ \/ / \ |
' \_/ |___/_/ \_\ |
' |
'///////////////////|
'==============================================================
'//////////////////////////////////////////////////////////////
Private Sub GSpeech_OnTime_test()
Dim S$
'Chinese: S = ThisWorkbook.VBProject.VBComponents("form_GSpeechXL").Designer.Controls("Label1").Caption
'Japanese: S = ThisWorkbook.VBProject.VBComponents("form_GSpeechXL").Designer.Controls("Label2").Caption
'Korea: S = ThisWorkbook.VBProject.VBComponents("form_GSpeechXL").Designer.Controls("Label3").Caption
'Arabi: S = ThisWorkbook.VBProject.VBComponents("form_GSpeechXL").Designer.Controls("Label4").Caption
'Vietnamese: S = ThisWorkbook.VBProject.VBComponents("form_GSpeechXL").Designer.Controls("Label5").Caption
SpeechXL S, "vi", 1, 100
End Sub
'//////////////////////////////////////////////////////////////
'///////////////////|
' __ _____ _ ® |
' \ \ / / _ | / \ |
' \ \ /| _ \/ / \ |
' \_/ |___/_/ \_\ |
' |
'///////////////////|
' Main Function
'==============================================================
Function SpeechXL(ByVal Text As String, _
Optional ByVal LangSpeakDefault As String = "", _
Optional ByVal Speed As Double = 1.2, _
Optional ByVal Volume As Byte = 90, _
Optional ByVal oAPP As Object) As String
On Error Resume Next
SpeechXL = "Speech"
PNP.Speed = VBA.IIf(Speed < 0.5, 0.5, VBA.IIf(Speed > 4, 4, Speed))
PNP.Volume = VBA.IIf(Volume < 20, 20, VBA.IIf(Volume > 100, 100, Volume))
Pri_Text = Text
Pri_LangSpeakDefault = LangSpeakDefault
Set APP_ = oAPP
If Pri_TimerID <> 0 Then KillTimer 0&, Pri_TimerID
Pri_TimerID = SetTimer(0&, 0&, 0, AddressOf SpeechXL_Run)
End Function
'//////////////////////////////////////////////////////////////
Public Sub GSPEECH_STOP()
On Error GoTo Main
oSpeechXL.Parent.OnTime VBA.Now, "'" & ROOT_FILE_SV & "'!GSPEECH_End"
Exit Sub
Main:
Application.OnTime VBA.Now, "'" & ThisWorkbook.Name & "'!GSPEECH_End"
End Sub
'///////////////////|
' __ _____ _ ® |
' \ \ / / _ | / \ |
' \ \ /| _ \/ / \ |
' \_/ |___/_/ \_\ |
' |
'///////////////////|
' START APP WITH NEW PROCESS
'==============================================================
Private Sub GSPEECH_OPEN_SV_RUN()
Call GSPEECH_OPEN_SV(True)
End Sub
'//////////////////////////////////////////////////////////////
Private Sub ShowWindowUI()
#If Win64 Then
Dim hwnd As LongPtr
#Else
Dim hwnd As Long
#End If
Static I As Long
I = VBA.IIf(I = 0, 9, 0)
Dim WB As Object
Set WB = oSpeechXL
If WB Is Nothing Then Exit Sub
hwnd = WB.Parent.hwnd
ShowWindow hwnd, I
End Sub
'//////////////////////////////////////////////////////////////
Private Sub CloseAppX()
Call IsOpenX(True)
End Sub
'///////////////////|
' __ _____ _ ® |
' \ \ / / _ | / \ |
' \ \ /| _ \/ / \ |
' \_/ |___/_/ \_\ |
' |
'///////////////////|
' PATH
'==============================================================
Private Function PATH_SYS_TEMP() As String
PATH_SYS_TEMP = VBA.IIf(VBA.Environ("tmp") <> "", VBA.Environ("tmp"), VBA.Environ("temp"))
End Function
'//////////////////////////////////////////////////////////////
Private Function PATH_GSPEECH_STARTUP() As String
PATH_GSPEECH_STARTUP = Application.StartupPath & "\" & ROOT_FILE_SV
End Function
'//////////////////////////////////////////////////////////////
Private Function ROOT_NAME_() As String
ROOT_NAME_ = ROOT_NAME & CStr(PNP.Index Mod 2)
End Function
'//////////////////////////////////////////////////////////////
Private Sub GSPEECH_Kill()
On Error Resume Next
Call GSPEECH_PlayerStop
Call VBA.Kill(PATH_SYS_TEMP & "\" & ROOT_NAME & "\translate_tts1.mp3")
Call VBA.Kill(PATH_SYS_TEMP & "\" & ROOT_NAME & "\*.*")
End Sub
'///////////////////|
' __ _____ _ ® |
' \ \ / / _ | / \ |
' \ \ /| _ \/ / \ |
' \_/ |___/_/ \_\ |
' |
'///////////////////|
'==============================================================
' GOOGLE Speech Start
'==============================================================
'//////////////////////////////////////////////////////////////
Private Sub GSPEECH_Status(Optional Clean As Boolean)
If APP_ Is Nothing Then
Application.StatusBar = VBA.IIf(Clean, "", PNP.list(2, PNP.Index))
Else
APP_.StatusBar = VBA.IIf(Clean, "", PNP.list(2, PNP.Index))
End If
End Sub
'//////////////////////////////////////////////////////////////
Private Sub GSPEECH_PlayerStop()
On Error Resume Next
Call mciSendString("Close " & ROOT_NAME & "1", "", 0, 0)
Call mciSendString("Close " & ROOT_NAME & "0", "", 0, 0)
Call GSPEECH_Status(True)
End Sub
'//////////////////////////////////////////////////////////////
Private Sub GSPEECH_End()
On Error Resume Next
Call GSPEECH_PlayerStop
Application.OnTime VBA.Now, "'" & ThisWorkbook.Name & "'!GSPEECH_PlayerStop", , False
Application.OnTime DoTime, "'" & ThisWorkbook.Name & "'!GSpeech_CheckPlayNext", , False
'Application.OnTime VBA.Now, "'" & ThisWorkbook.Name & "'!GSPEECH_Kill"
Call GSPEECH_Status(True)
Set APP_ = Nothing
On Error GoTo 0
End Sub
'//////////////////////////////////////////////////////////////
Private Sub GSPEECH_OPEN_SV(Optional Reset As Boolean, Optional Timeout As Integer = 0)
Call copyProject(Reset)
'VBA.Shell "cmd.exe /S /C timeout /t " & Timeout & " /nobreak " & _
"&& START """ & ROOT_NAME & """ """ & Application.Path & "\EXCEL.EXE"" /x " & parameter & " """ & PATH_GSPEECH_STARTUP & """", 0
VBA.Shell "cmd.exe /S /C START """ & ROOT_NAME & """ """ & Application.Path & "\EXCEL.EXE"" /x " & parameter & " """ & PATH_GSPEECH_STARTUP & """", 0
End Sub
'//////////////////////////////////////////////////////////////
Private Sub SpeechXL_Run()
If Pri_TimerID <> 0 Then KillTimer 0&, Pri_TimerID
On Error GoTo Main
oSpeechXL.Parent.Run "'" & ROOT_FILE_SV & "'!GSpeech_OnTime", Pri_Text, Pri_LangSpeakDefault, PNP.Speed, PNP.Volume
Exit Sub
Main:
Application.Run "'" & ThisWorkbook.Name & "'!GSpeech_OnTime", Pri_Text, Pri_LangSpeakDefault, PNP.Speed, PNP.Volume
End Sub
'//////////////////////////////////////////////////////////////
Private Sub GSpeech_OnTime(ByVal Text As String, _
Optional ByVal LangSpeakDefault$ = "", _
Optional ByVal Speed As Double = 1.3, _
Optional ByVal Volume As Byte = 90, _
Optional ByVal oAPP As Object)
PNP.Index = 0
PNP.Speed = VBA.IIf(Speed < 0.5, 0.5, VBA.IIf(Speed > 4, 4, Speed))
PNP.Volume = VBA.IIf(Volume < 20, 20, VBA.IIf(Volume > 100, 100, Volume))
Pri_Text = Text: Pri_LangSpeakDefault = LangSpeakDefault
Set APP_ = oAPP
Application.OnTime VBA.Now, "'" & ThisWorkbook.Name & "'!GSpeech_Run"
End Sub
'//////////////////////////////////////////////////////////////
Private Sub GSpeech_Run()
On Error Resume Next
If Pri_Text = "" Then Exit Sub
'--------------------------------------
Dim iRun As Boolean, Hieroglyphs As Boolean
Dim L%, I%, K%, Ti As Double, total()
Dim Text As String, T As String, LT As String, rT As String, Tmp As String, URL$
Dim gspeech_temp As String
gspeech_temp = PATH_SYS_TEMP & "\" & ROOT_NAME & "\"
Call GSPEECH_PlayerStop
Call CreateFolder(gspeech_temp)
Const Link = "translate.google.com/translate_tts?ie=utf-8&client=tw-ob&tl="
If Pri_LangSpeakDefault = "" Then GoSub Detect
Select Case VBA.LCase(Pri_LangSpeakDefault)
Case "ja", "zh-cn", "zh-tw", "ar", "ko": Hieroglyphs = True
End Select
URL = "http://" & Link & Pri_LangSpeakDefault & "&q="
'--------------------------------------
GoSub Disjoint
If K > 0 And Not iRun Then
Call GSpeech_ListPlayNext
End If
Exit Sub
Disjoint:
K = 0
Text = Pri_Text
Do
L = Len(Text): If L <= 0 Then Exit Do
K = K + 1
ReDim Preserve total(1 To 2, 1 To K)
total(1, K) = gspeech_temp & "translate_tts" & K & ".mp3"
If L <= LimitLen Then total(2, K) = Text: GoSub MakeArr: Exit Do
total(2, K) = VBA.Left(Text, LimitLen)
rT = VBA.Right(Text, L - LimitLen)
If Not Hieroglyphs Then
I = VBA.InStrRev(1, total(2, K), " ")
If I + 20 > LimitLen Then
total(2, K) = VBA.Left(total(2, K), I - 1)
rT = VBA.Right(Text, L - I - 2)
If VBA.Left(rT, 1) Like "[,;:._ ]" Then rT = VBA.Right(rT, Len(rT) - 1)
End If
End If
Text = rT
GoSub MakeArr
DoEvents
Loop
Return
MakeArr:
DoEvents
Tmp = VBA.Replace(VBA.Replace(VBA.Replace(VBA.Replace(total(2, K), ")", "."), "(", "."), "]", "."), "[", ".")
If URLDownloadToFile(0, URL & EncodeURL(Tmp), total(1, K), 0, 0) <> 0 Then
GoTo EndAndKill
End If
total(1, K) = ShortPath(total(1, K))
PNP.list = total
If Not iRun Then
iRun = Dir(gspeech_temp & "translate_tts1.mp3", vbSystem) <> ""
If iRun Then Call GSpeech_ListPlayNext
End If
Return
Detect:
DoEvents
If Pri_Text = "" Then Return
Dim strInput$
With oGlb_WinHttp_DL 'VBA.CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "GET", "https://translate.googleapis.com/translate_a/single?client=gtx&sl=auto" & _
VBA.IIf("" <> "&tl=", "", "&tl=vi") & "&dt=t&q=" & _
EncodeURL(Left(Replace(Pri_Text, Chr(10), " "), 50)), False
.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
.setRequestHeader "Content-Type", "applicaton/X-www-form-urlencoded"
.Send "": If .Status <> 200 Then GoTo EndAndKill
strInput = VBA.Replace(.responseText, VBA.Chr(10), "")
Pri_LangSpeakDefault = VBA.Replace(VBA.Replace(VBA.Split(VBA.Right(strInput, Len(strInput) - VBA.InStr(strInput, "],[""") - 2), "],")(0), """", ""), "]", "")
strInput = ""
End With
Return
EndAndKill:
Application.OnTime VBA.Now, "'" & ThisWorkbook.Name & "'!GSpeech_End"
End Sub
'//////////////////////////////////////////////////////////////
Private Sub GSpeech_ListPlayNext()
On Error Resume Next
Application.OnTime DoTime, "'" & ThisWorkbook.Name & "'!GSpeech_CheckPlayNext", , False
'-----------------------------
Dim idx As Long, ListCount As Long
ListCount = UBound(PNP.list, 2)
idx = PNP.Index + 1
If idx <= ListCount Then
PNP.Index = idx
PNP.File = PNP.list(1, idx)
Call GSpeech_FileOpen
DoTime = (GSpeech_GetLength - 2500)
DoTime = VBA.IIf(DoTime < 1000, 0, DoTime / 1000 / PNP.Speed)
DoTime = VBA.Now + VBA.TimeSerial(0, 0, DoTime)
Application.OnTime DoTime, "'" & ThisWorkbook.Name & "'!GSpeech_CheckPlayNext"
Call GSPEECH_Status
Else
Application.OnTime VBA.Now + VBA.TimeSerial(0, 0, 1), "'" & ThisWorkbook.Name & "'!GSPEECH_PlayerStop"
End If
On Error GoTo 0
End Sub
'//////////////////////////////////////////////////////////////
Private Sub GSpeech_CheckPlayNext()
Dim T1 As Long, T2 As Long
T1 = GSpeech_GetCurPos: T2 = GSpeech_GetLength
If T1 = 0 Or T2 = 0 Then Exit Sub
If T1 >= T2 - 1000 Then
Application.OnTime VBA.Now, "'" & ThisWorkbook.Name & "'!GSpeech_ListPlayNext"
Else
Application.OnTime VBA.Now + VBA.TimeSerial(0, 0, 1) * 0.7, "'" & ThisWorkbook.Name & "'!GSpeech_CheckPlayNext"
End If
End Sub
'//////////////////////////////////////////////////////////////
Private Sub GSpeech_FileOpen()
Dim lRet&, sError As String * 255
Call mciSendString("Close " & ROOT_NAME_, "", 0, 0)
lRet = mciSendString("open """ & PNP.File & """ alias " & ROOT_NAME_, "", 0, 0)
If lRet <> 0 Then mciGetErrorString lRet, sError, 255: Exit Sub
Call mciSendString("set " & ROOT_NAME_ & " Speed " & CStr(Int(PNP.Speed * 1000)), "", 0, 0)
Call mciSendString("setaudio " & ROOT_NAME_ & " Volume to " & PNP.Volume * 10, "", 0, 0)
Call mciSendString("Play " & ROOT_NAME_, "", 0, 0)
End Sub
'//////////////////////////////////////////////////////////////
Private Function GSpeech_info() As String
Dim lRet&, S As String * 255: S = VBA.Space(255): lRet = 255
On Error Resume Next
Call mciSendString("info " & ROOT_NAME_ & " file", S, lRet, 0)
GSpeech_info = VBA.Left(S, VBA.InStr(S, VBA.vbNullChar) - 1)
On Error GoTo 0
End Function
'//////////////////////////////////////////////////////////////
Private Function GSpeech_GetLength() As Long
Dim lRet&, S As String * 255: S = VBA.Space(255)
On Error Resume Next
lRet = mciSendString("status " & ROOT_NAME_ & " length", S, 255, 0)
If lRet = 0 Then GSpeech_GetLength& = CLng(S)
On Error GoTo 0
End Function
'//////////////////////////////////////////////////////////////
Private Function GSpeech_GetCurPos() As Long
Dim lRet&, S As String * 255: S = VBA.Space(255)
On Error Resume Next
lRet = mciSendString("status " & ROOT_NAME_ & " position wait", S, 255, 0)
If lRet = 0 Then GSpeech_GetCurPos = CLng(S)
On Error GoTo 0
End Function
'///////////////////|
' __ _____ _ ® |
' \ \ / / _ | / \ |
' \ \ /| _ \/ / \ |
' \_/ |___/_/ \_\ |
' |
'///////////////////|
Private Function EncodeURL(strText)
Static objHtmlfile As Object
If objHtmlfile Is Nothing Then
Set objHtmlfile = VBA.CreateObject("htmlfile")
objHtmlfile.parentWindow.execScript "function encode(s) {return encodeURIComponent(s)}", "jscript"
End If
EncodeURL = objHtmlfile.parentWindow.encode(strText)
End Function
'//////////////////////////////////////////////////////////////
Private Function ShortPath(ByVal LongPath As String) As String
Dim ret&, Buff As String * 512
ret = GetShortPathName(StrConv(LongPath, 64), Buff, 512)
ShortPath = Left(StrConv(Buff, 128), ret)
End Function
'//////////////////////////////////////////////////////////////
Private Function CreateFolder(ByVal FolderPath As String, Optional ByRef FileSystem As Object) As Boolean
Dim FolderArray, Tmp$, I As Integer, UB As Integer, tFolder$
tFolder = FolderPath
If VBA.Right(tFolder, 1) = "\" Then tFolder = VBA.Left(tFolder, VBA.Len(tFolder) - 1)
If tFolder Like "\\*\*" Then tFolder = VBA.Strings.Replace(tFolder, "\", "@", 1, 3)
FolderArray = VBA.Split(tFolder, "\")
FolderArray(0) = VBA.Strings.Replace(FolderArray(0), "@", "\", 1, 3)
On Error GoTo Ends
If FileSystem Is Nothing Then
Set FileSystem = oGlb_FSO 'VBA.CreateObject("Scripting.FileSystemObject")
End If
UB = UBound(FolderArray)
With FileSystem
For I = 0 To UB
Tmp = Tmp & FolderArray(I) & "\"
If Not .FolderExists(Tmp) Then .CreateFolder (Tmp)
CreateFolder = (I = UB) And Len(FolderArray(I)) > 0 And FolderArray(I) <> " "
Next
End With
Ends:
End Function
'//////////////////////////////////////////////////////////////
Private Function oSpeechXL() As Object
Static o As Object, X As Boolean
If o Is Nothing And Not X Then
X = IsOpenX: If X Then Set o = VBA.GetObject(PATH_GSPEECH_STARTUP)
End If
Set oSpeechXL = o
End Function
'//////////////////////////////////////////////////////////////
Private Function oGlb_FSO() As Object
Static o As Object
If o Is Nothing Then Set o = VBA.CreateObject("Scripting.FileSystemObject")
Set oGlb_FSO = o
End Function
'//////////////////////////////////////////////////////////////
Private Function oGlb_WinHttp_DL() As Object
Static o As Object
If o Is Nothing Then Set o = VBA.CreateObject("WinHttp.WinHttpRequest.5.1")
Set oGlb_WinHttp_DL = o
End Function
'//////////////////////////////////////////////////////////////
Private Function IsOpenA(ByVal FileName As String) As Boolean
Const INVALID_HANDLE_VALUE = -1
Const ERROR_SHARING_VIOLATION = 32
#If Win64 Then
Dim hFile As LongPtr
#Else
Dim hFile As Long
#End If
hFile = CreateFileW(VBA.StrConv(FileName, vbUnicode), GENERIC_READ, FILE_SHARE_READ, 0&, OPEN_ALWAYS, 0, 0)
If hFile = INVALID_HANDLE_VALUE Then
If GetLastError() = ERROR_SHARING_VIOLATION Then
Else
End If
IsOpenA = True
Else
CloseHandle hFile
End If
End Function
'//////////////////////////////////////////////////////////////
Private Function IsOpenX(Optional terminate As Boolean, Optional bKill As Boolean) As Boolean
On Error Resume Next
Dim F As String, o
F = PATH_GSPEECH_STARTUP
If Not IsOpenA(F) Then Exit Function
For Each o In VBA.GetObject("winmgmts:\\.\root\cimv2").ExecQuery("Select * from Win32_Process Where Name ='excel.exe'")
If VBA.LCase(o.commandLine) Like VBA.LCase("*/x *" & parameter & " *" & F & "*") Then
If terminate Then
If bKill Then Kill F
o.terminate
End If
IsOpenX = True: Exit For
End If
Next
On Error GoTo 0
End Function
'//////////////////////////////////////////////////////////////
Private Sub ClientApp_Close()
On Error Resume Next
Workbooks(ROOT_FILE_SV).Close False
On Error GoTo 0
End Sub
'//////////////////////////////////////////////////////////////
Private Sub copyProject(Optional Reset As Boolean)
On Error Resume Next
Dim P As String, K As Integer, WB As Object
P = PATH_GSPEECH_STARTUP
If StrComp(ThisWorkbook.Name, ROOT_FILE, 1) <> 0 Then Exit Sub
If VBA.Dir(P, vbSystem) <> "" Then
If Reset Then
Set WB = Workbooks(ROOT_FILE_SV)
If StrComp(WB.FullName, P, 1) = 0 Then
WB.Close False
End If
Call IsOpenX(True)
Kill P
Do Until VBA.Dir(P, vbSystem) = ""
Application.Wait VBA.Now + VBA.TimeSerial(0, 0, 1)
K = K + 1: If K > 5 Then Exit Do
Loop
ThisWorkbook.SaveCopyAs P
End If
Else
ThisWorkbook.SaveCopyAs P
End If
K = 0
Do Until VBA.Dir(P, vbSystem) <> ""
Application.Wait VBA.Now + VBA.TimeSerial(0, 0, 1)
K = K + 1: If K > 5 Then Exit Do
Loop
On Error GoTo 0
End Sub
'//////////////////////////////////////////////////////////////
Private Sub GSpeech_Selection()
End Sub
Private Sub GSpeech_Settings()
On Error Resume Next
Dim V As Boolean
V = form_GSpeechXL.Visible
If Not V Then form_GSpeechXL.Show 0 Else VBA.Unload form_GSpeechXL
On Error GoTo 0
End Sub
'//////////////////////////////////////////////////////////////
Sub DesignerChangeThemeOfFormxxx()
Dim oCur As Object, VBComp
On Error Resume Next
Set VBComp = ThisWorkbook.VBProject.VBComponents("form_GSpeechXL")
Set oCur = VBComp.Designer.Controls("btn_Exit").MouseIcon
Dim Ctr
For Each Ctr In VBComp.Designer.Controls
Select Case VBA.Left(VBA.LCase(Ctr.Name), 3)
Case "spe", "vol"
Ctr.MousePointer = 99
Set Ctr.MouseIcon = oCur
End Select
Next
End Sub
'//////////////////////////////////////////////////////////////
Private Function googleLanguageSupport( _
Optional SingleList As Integer = 0, _
Optional Auto As Boolean) As Variant
' Last Edit: 31/03/2020 21:54
Dim Arr()
If Auto Then
ReDim Arr(1 To 2, 104)
Arr(1, 0) = "Auto": Arr(2, 0) = "Auto"
Else
ReDim Arr(1 To 2, 1 To 104)
End If
Arr(1, 1) = "English": Arr(2, 1) = "en"
Arr(1, 2) = "Afrikaans": Arr(2, 2) = "af"
Arr(1, 3) = "Albanian": Arr(2, 3) = "sq"
Arr(1, 4) = "Amharic": Arr(2, 4) = "am"
Arr(1, 5) = "Arabic": Arr(2, 5) = "ar"
Arr(1, 6) = "Armenian": Arr(2, 6) = "hy"
Arr(1, 7) = "Azerbaijani": Arr(2, 7) = "az"
Arr(1, 8) = "Basque": Arr(2, 8) = "eu"
Arr(1, 9) = "Belarusian": Arr(2, 9) = "be"
Arr(1, 10) = "Bengali": Arr(2, 10) = "bn"
Arr(1, 11) = "Bosnian": Arr(2, 11) = "bs"
Arr(1, 12) = "Bulgarian": Arr(2, 12) = "bg"
Arr(1, 13) = "Catalan": Arr(2, 13) = "ca"
Arr(1, 14) = "Cebuano": Arr(2, 14) = "ceb"
Arr(1, 15) = "Chinese (Simplified)": Arr(2, 15) = "zh-CN"
Arr(1, 16) = "Chinese (Traditional)": Arr(2, 16) = "zh-TW"
Arr(1, 17) = "Corsican": Arr(2, 17) = "co"
Arr(1, 18) = "Croatian": Arr(2, 18) = "hr"
Arr(1, 19) = "Czech": Arr(2, 19) = "cs"
Arr(1, 20) = "Danish": Arr(2, 20) = "da"
Arr(1, 21) = "Dutch": Arr(2, 21) = "nl"
Arr(1, 22) = "Esperanto": Arr(2, 22) = "eo"
Arr(1, 23) = "Estonian": Arr(2, 23) = "et"
Arr(1, 24) = "Finnish": Arr(2, 24) = "fi"
Arr(1, 25) = "French": Arr(2, 25) = "fr"
Arr(1, 26) = "Frisian": Arr(2, 26) = "fy"
Arr(1, 27) = "Galician": Arr(2, 27) = "gl"
Arr(1, 28) = "Georgian": Arr(2, 28) = "ka"
Arr(1, 29) = "German": Arr(2, 29) = "de"
Arr(1, 30) = "Greek": Arr(2, 30) = "el"
Arr(1, 31) = "Gujarati": Arr(2, 31) = "gu"
Arr(1, 32) = "Haitian Creole": Arr(2, 32) = "ht"
Arr(1, 33) = "Hausa": Arr(2, 33) = "ha"
Arr(1, 34) = "Hawaiian": Arr(2, 34) = "haw"
Arr(1, 35) = "Hebrew": Arr(2, 35) = "he or iw"
Arr(1, 36) = "Hindi": Arr(2, 36) = "hi"
Arr(1, 37) = "Hmong": Arr(2, 37) = "hmn"
Arr(1, 38) = "Hungarian": Arr(2, 38) = "hu"
Arr(1, 39) = "Icelandic": Arr(2, 39) = "is"
Arr(1, 40) = "Igbo": Arr(2, 40) = "ig"
Arr(1, 41) = "Indonesian": Arr(2, 41) = "id"
Arr(1, 42) = "Irish": Arr(2, 42) = "ga"
Arr(1, 43) = "Italian": Arr(2, 43) = "it"
Arr(1, 44) = "Japanese": Arr(2, 44) = "ja"
Arr(1, 45) = "Javanese": Arr(2, 45) = "jv"
Arr(1, 46) = "Kannada": Arr(2, 46) = "kn"
Arr(1, 47) = "Kazakh": Arr(2, 47) = "kk"
Arr(1, 48) = "Khmer": Arr(2, 48) = "km"
Arr(1, 49) = "Korean": Arr(2, 49) = "ko"
Arr(1, 50) = "Kurdish": Arr(2, 50) = "ku"
Arr(1, 51) = "Kyrgyz": Arr(2, 51) = "ky"
Arr(1, 52) = "Lao": Arr(2, 52) = "lo"
Arr(1, 53) = "Latin": Arr(2, 53) = "la"
Arr(1, 54) = "Latvian": Arr(2, 54) = "lv"
Arr(1, 55) = "Lithuanian": Arr(2, 55) = "lt"
Arr(1, 56) = "Luxembourgish": Arr(2, 56) = "lb"
Arr(1, 57) = "Macedonian": Arr(2, 57) = "mk"
Arr(1, 58) = "Malagasy": Arr(2, 58) = "mg"
Arr(1, 59) = "Malay": Arr(2, 59) = "ms"
Arr(1, 60) = "Malayalam": Arr(2, 60) = "ml"
Arr(1, 61) = "Maltese": Arr(2, 61) = "mt"
Arr(1, 62) = "Maori": Arr(2, 62) = "mi"
Arr(1, 63) = "Marathi": Arr(2, 63) = "mr"
Arr(1, 64) = "Mongolian": Arr(2, 64) = "mn"
Arr(1, 65) = "Myanmar (Burmese)": Arr(2, 65) = "my"
Arr(1, 66) = "Nepali": Arr(2, 66) = "ne"
Arr(1, 67) = "Norwegian": Arr(2, 67) = "no"
Arr(1, 68) = "Nyanja (Chichewa)": Arr(2, 68) = "ny"
Arr(1, 69) = "Pashto": Arr(2, 69) = "ps"
Arr(1, 70) = "Persian": Arr(2, 70) = "fa"
Arr(1, 71) = "Polish": Arr(2, 71) = "pl"
Arr(1, 72) = "Portuguese (Portugal, Brazil)": Arr(2, 72) = "pt"
Arr(1, 73) = "Punjabi": Arr(2, 73) = "pa"
Arr(1, 74) = "Romanian": Arr(2, 74) = "ro"
Arr(1, 75) = "Russian": Arr(2, 75) = "ru"
Arr(1, 76) = "Samoan": Arr(2, 76) = "sm"
Arr(1, 77) = "Scots Gaelic": Arr(2, 77) = "gd"
Arr(1, 78) = "Serbian": Arr(2, 78) = "sr"
Arr(1, 79) = "Sesotho": Arr(2, 79) = "st"
Arr(1, 80) = "Shona": Arr(2, 80) = "sn"
Arr(1, 81) = "Sindhi": Arr(2, 81) = "sd"
Arr(1, 82) = "Sinhala (Sinhalese)": Arr(2, 82) = "si"
Arr(1, 83) = "Slovak": Arr(2, 83) = "sk"
Arr(1, 84) = "Slovenian": Arr(2, 84) = "sl"
Arr(1, 85) = "Somali": Arr(2, 85) = "so"
Arr(1, 86) = "Spanish": Arr(2, 86) = "es"
Arr(1, 87) = "Sundanese": Arr(2, 87) = "su"
Arr(1, 88) = "Swahili": Arr(2, 88) = "sw"
Arr(1, 89) = "Swedish": Arr(2, 89) = "sv"
Arr(1, 90) = "Tagalog (Filipino)": Arr(2, 90) = "tl"
Arr(1, 91) = "Tajik": Arr(2, 91) = "tg"
Arr(1, 92) = "Tamil": Arr(2, 92) = "ta"
Arr(1, 93) = "Telugu": Arr(2, 93) = "te"
Arr(1, 94) = "Thai": Arr(2, 94) = "th"
Arr(1, 95) = "Turkish": Arr(2, 95) = "tr"
Arr(1, 96) = "Ukrainian": Arr(2, 96) = "uk"
Arr(1, 97) = "Urdu": Arr(2, 97) = "ur"
Arr(1, 98) = "Uzbek": Arr(2, 98) = "uz"
Arr(1, 99) = "Vietnamese": Arr(2, 99) = "vi"
Arr(1, 100) = "Welsh": Arr(2, 100) = "cy"
Arr(1, 101) = "Xhosa": Arr(2, 101) = "xh"
Arr(1, 102) = "Yiddish": Arr(2, 102) = "yi"
Arr(1, 103) = "Yoruba": Arr(2, 103) = "yo"
Arr(1, 104) = "Zulu": Arr(2, 104) = "zu"
Select Case SingleList
Case 1: googleLanguageSupport = Application.Index(Arr, 1, 0)
Case 2: googleLanguageSupport = Application.Index(Arr, 2, 0)
Case Else: googleLanguageSupport = Arr
End Select
End Function
