'Google Language Codes - full list at
Add Reference "Microsoft Internet Controls" (Tools>References)

#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
    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()
Dim inputText As String
Dim translation As String
    inputText = InputBox("Enter text to translate")
    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(ByVal text As String, _
                       Optional ByVal fromLanguage As String = "en", _
                       Optional ByVal toLanguage As String = "es")
                                As String

    Static objHTTP As Object
    Dim URL As String
    If objHTTP Is Nothing Then
       Set objHTTP = CreateObject("MSXML2.XMLHTTP")
    End If
    URL = "" & fromLanguage & "&sl=" & fromLanguage & "&tl=" & toLanguage & _
          "&ie=UTF-8&prev=_m&q=" & WorksheetFunction.EncodeURL(text)
    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>"))
            GoogleTranslate = CVErr(xlErrValue)
        End If
    End With
End Function

Private Function Clean(ByVal val As String) As String
    val = Replace(val, """, """")
    val = Replace(val, "%2C", ",")
    val = Replace(val, "'", "'")
    Clean = val
End Function

Private Function RegexExecute(ByVal str As String, _
                              ByVal reg As String, _
                     Optional ByVal matchIndex As Long, _
                     Optional ByVal subMatchIndex As Long) As String

Dim RegEx As Variant
Dim match As Variant
Dim Matches As Variant

    On Error GoTo ErrorHandler

    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
    RegexExecute = CVErr(xlErrValue)
End Function

Private Function MsgBoxW(ByVal Prompt As String,
                Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly,
                Optional ByVal 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

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.
    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, ArgumentDescriptions:=strArgs, Category:="Custom Category"
End Sub

Public Sub DeregisterGoogleTranslateFunction()
    Dim strFunc As String
    strFunc = "GoogleTranslate"
    Application.MacroOptions Macro:=strFunc, Description:=Empty, Category:=Empty
End Sub

© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited TopPrevNext