Option Explicit
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
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
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
URL = "https://translate.google.com/m?hl=" & fromLanguage & "&sl=" & fromLanguage & "&tl=" & toLanguage & "&ie=UTF-8&prev=_m&q=" & WorksheetFunction.EncodeURL(text)
Else
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
Title = Title & vbNullChar
MsgBoxW = MessageBoxW(Application.hWnd, StrPtr(Prompt), StrPtr(Title), Buttons)
End Function
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")
.Mode = adModeReadWrite
.Type = adTypeText
.Charset = "UTF-8"
.Open
.WriteText StringVal
.Position = 0
.Type = adTypeBinary
.Position = 3
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
Dim strDesc As String
Dim strArgs() As String
ReDim strArgs(1 To 3)
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 Macro:=strFunc, Description:=strDesc, Category:="User Defined", ArgumentDescriptions:=strArgs
#Else
Application.MacroOptions Macro:=strFunc, Description:=strDesc, Category:="User Defined"
End Sub
Public Sub DeregisterGoogleTranslateFunction()
Dim strFunc As String
strFunc = "GoogleTranslate"
Application.MacroOptions Macro:=strFunc, Description:=Empty, Category:=Empty
End Sub
