Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function MessageBoxW Lib "user32" (ByVal hWnd As LongPtr, ByVal lpText As LongPtr, ByVal lpCaption As LongPtr, ByVal uType As Long) As Long
#Else
Private Declare Function MessageBoxW Lib "user32" (ByVal hWnd As Long, ByVal lpText As Long, ByVal lpCaption As Long, ByVal uType As Long) As Long
#End If
Public Sub Test_GoogleTranslate()
Dim inputText As String, translation As String
inputText = InputBox("Enter English text to translate to Spanish")
If inputText <> "" Then
translation = GoogleTranslate(inputText, "en", "es")
Range("A1").Value = inputText
Range("A2").Value = translation
MsgBoxW inputText & vbCrLf & translation
End If
End Sub
'Google Language Codes - full list at https://cloud.google.com/translate/docs/languages/
'Auto Detect = 0 Bulgarian = bg Finnish = fi Hungarian = hu Latvian = lv Russian = ru Turkish = tr
'English = en Catalan = ca French = fr Icelandic = is Lithuanian = lt Serbian = sr Ukrainian = uk
'Afrikaans = af Chinese = zh Galician = gl Indonesian = id Macedonian = mk Slovak = sk Urdu = ur
'Albanian = sq Croatian = hr Georgian = ka Irish = ga Malay = ms Slovenian = sl Vietnamese = vi
'Arabic = ar Czech = cs German = de Italian = it Maltese = mt Spanish = es Welsh = cy
'Armenian = hy Danish = da Greek = el Japanese = ja Norwegian = no Swahili = sw Yiddish = yi
'Azerbaijani = az Dutch = nl Gujarati = gu Kannada = kn Persian = fa Swedish = sv
'Basque = eu Esperanto = eo Haitian_Creole = ht Korean = ko Polish = pl Tamil = ta
'Belarusian = be Estonian = et Hebrew = iw Lao = lo Portuguese = pt Telugu = te
'Bengali = bn Filipino = tl Hindi = hi Latin = la Romanian = ro Thai = th
Public Function GoogleTranslate(text As String, Optional fromLanguage As String = "en", Optional toLanguage As String = "es") As String
Static objHTTP As Object
Dim URL As String
If objHTTP Is Nothing Then Set objHTTP = CreateObject("MSXML2.XMLHTTP")
If Val(Application.Version) >= 15 Then
'Excel 2013 and later versions - encode the Google Translate URL using the WorksheetFunction.EncodeURL function
URL = "https://translate.google.com/m?hl=" & fromLanguage & "&sl=" & fromLanguage & "&tl=" & toLanguage & "&ie=UTF-8&prev=_m&q=" & WorksheetFunction.EncodeURL(text)
Else
'Excel 2010 and earlier versions - encode the Google Translate URL using our own URLEncode function
URL = "https://translate.google.com/m?hl=" & fromLanguage & "&sl=" & fromLanguage & "&tl=" & toLanguage & "&ie=UTF-8&prev=_m&q=" & URLEncode(text)
End If
With objHTTP
.Open "GET", URL, False
.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
.Send ("")
If InStr(.responseText, "<div class=""result-container""") > 0 Then
GoogleTranslate = Clean(RegexExecute(.responseText, "div[^""]*?""result-container"".*?>(.+?)</div>"))
Else
GoogleTranslate = CVErr(xlErrValue)
End If
End With
End Function
Private Function Clean(Val As String) As String
Val = Replace(Val, """, """")
Val = Replace(Val, "%2C", ",")
Val = Replace(Val, "'", "'")
Clean = Val
End Function
Private Function RegexExecute(str As String, reg As String, Optional matchIndex As Long, Optional subMatchIndex As Long) As String
Static RegEx As Object
Dim matches As Object
On Error GoTo ErrorHandler
If RegEx Is Nothing Then Set RegEx = CreateObject("VBScript.RegExp")
RegEx.Pattern = reg
RegEx.Global = Not (matchIndex = 0 And subMatchIndex = 0)
If RegEx.Test(str) Then
Set matches = RegEx.Execute(str)
RegexExecute = matches(matchIndex).SubMatches(subMatchIndex)
Exit Function
End If
ErrorHandler:
RegexExecute = CVErr(xlErrValue)
End Function
Private Function MsgBoxW(Prompt As String, Optional Buttons As VbMsgBoxStyle = vbOKOnly, Optional Title As String = "Microsoft Excel") As VbMsgBoxResult
Prompt = Prompt & vbNullChar 'Add null terminators
Title = Title & vbNullChar
MsgBoxW = MessageBoxW(Application.hWnd, StrPtr(Prompt), StrPtr(Title), Buttons)
End Function
'VBA function to URL-encode a string because WorksheetFunction.EncodeURL is only available in Excel 2013 and later
'https://stackoverflow.com/a/218199
'with late binding of Microsoft ActiveX Data Objects, so no VBA project reference is required
Public Function URLEncode(ByVal StringVal As String, Optional SpaceAsPlus As Boolean = False) As String
Dim bytes() As Byte, b As Byte, i As Integer, space As String
Const adTypeBinary = 1
Const adTypeText = 2
Const adModeReadWrite = 3
If SpaceAsPlus Then space = "+" Else space = "%20"
If Len(StringVal) > 0 Then
With CreateObject("ADODB.Stream") 'New ADODB.Stream
.Mode = adModeReadWrite
.Type = adTypeText
.Charset = "UTF-8"
.Open
.WriteText StringVal
.Position = 0
.Type = adTypeBinary
.Position = 3 ' skip BOM
bytes = .Read
End With
ReDim result(UBound(bytes)) As String
For i = UBound(bytes) To 0 Step -1
b = bytes(i)
Select Case b
Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
result(i) = Chr(b)
Case 32
result(i) = space
Case 0 To 15
result(i) = "%0" & Hex(b)
Case Else
result(i) = "%" & Hex(b)
End Select
Next i
URLEncode = Join(result, "")
End If
End Function
Public Sub RegisterGoogleTranslateFunction()
Dim strFunc As String 'name of the function you want to register
Dim strDesc As String 'description of the function itself
Dim strArgs() As String 'description of function arguments
ReDim strArgs(1 To 3) 'The upper bound is the number of arguments in your function
strFunc = "GoogleTranslate"
strDesc = "Translates a text string from the specified language (default English) to another language. Language codes are listed at https://cloud.google.com/translate/docs/languages/"
strArgs(1) = "Text string to translate."
strArgs(2) = "Translate FROM language code. Default ""en"" (English); use ""0"" to automatically detect the language."
strArgs(3) = "Translate TO language code. Default ""es"" (Spanish)."
'Application.MacroOptions arguments: [Macro], [Description], [HasMenu], [MenuText], [HasShortcutKey], [ShortcutKey], [Category], [StatusBar], [HelpContextID], [HelpFile], [ArgumentDescriptions]
#If VBA7 Then
'Excel 2010 and later - ArgumentDescriptions argument is supported
Application.MacroOptions Macro:=strFunc, Description:=strDesc, Category:="User Defined", ArgumentDescriptions:=strArgs
#Else
'Excel 2007 and earlier - ArgumentDescriptions argument is not supported
Application.MacroOptions Macro:=strFunc, Description:=strDesc, Category:="User Defined"
#End If
End Sub
Public Sub DeregisterGoogleTranslateFunction()
Dim strFunc As String 'name of the function you want to deregister
strFunc = "GoogleTranslate"
Application.MacroOptions Macro:=strFunc, Description:=Empty, Category:=Empty
End Sub
