[VBA][Outlook] Translate selected text in message editor to English or Thai using Google Translate.

GGTranslateOutlook.vba

Sub ETTranslate()
'Translate current text to Thai by replace original text

Dim msg As Outlook.MailItem
Dim insp As Outlook.Inspector

If Application.ActiveInspector Is Nothing Then
    If Application.ActiveExplorer.Selection.Count = 1 Then
        If Application.ActiveExplorer.Selection.Item(1).Class = olMail Then
            Set msg = Application.ActiveExplorer.Selection.Item(1)
        End If
    Else
        'to many items selected
        MsgBox "Please select one email"
    End If
Else
    Set insp = Application.ActiveInspector
    If insp.CurrentItem.Class = olMail Then
        Set msg = insp.CurrentItem
    End If
End If

If msg Is Nothing Then
    MsgBox "Could not determine the mail item"
Else
    If msg.GetInspector.EditorType = olEditorWord Then
        Set hed = msg.GetInspector.WordEditor
        Set appWord = hed.Application
        Set rng = appWord.Selection
        'MsgBox rng, vbInformation + vbOKOnly, "Before translation"
        s = rng.Text
        s = Translate(CStr(s))
        rng.Text = s
        'MsgBox rng, vbInformation + vbOKOnly, "After translation"
    End If
End If

Set appWord = Nothing
Set insp = Nothing
Set rng = Nothing
Set hed = Nothing
Set msg = Nothing

End Sub

Sub TETranslate()
'Translate current text to English by replace original text

Dim msg As Outlook.MailItem
Dim insp As Outlook.Inspector

If Application.ActiveInspector Is Nothing Then
    If Application.ActiveExplorer.Selection.Count = 1 Then
        If Application.ActiveExplorer.Selection.Item(1).Class = olMail Then
            Set msg = Application.ActiveExplorer.Selection.Item(1)
        End If
    Else
        'to many items selected
        MsgBox "Please select one email"
    End If
Else
    Set insp = Application.ActiveInspector
    If insp.CurrentItem.Class = olMail Then
        Set msg = insp.CurrentItem
    End If
End If

If msg Is Nothing Then
    MsgBox "Could not determine the mail item"
Else
    If msg.GetInspector.EditorType = olEditorWord Then
        Set hed = msg.GetInspector.WordEditor
        Set appWord = hed.Application
        Set rng = appWord.Selection
        'MsgBox rng, vbInformation + vbOKOnly, "Before translation"
        s = rng.Text
        s = Translate(CStr(s), , "en")
        rng.Text = s
        'MsgBox rng, vbInformation + vbOKOnly, "After translation"
    End If
End If

Set appWord = Nothing
Set insp = Nothing
Set rng = Nothing
Set hed = Nothing
Set msg = Nothing

End Sub

Function Translate(SText As String, Optional FromLang As String = "0", Optional ToLang As String = "th") As String
    ' Translate text using Google Translate
    Dim p1&, p2&, URL$, resp$, d1$
    Dim xmlhttp As New MSXML2.XMLHTTP60 'Must add references (Tools>References) Microsoft XML v 6.0
    
    Const URL_TEMPLATE$ = "https://translate.google.co.th/m?sl=[from]&tl=[to]&hl=[from]&q="
    Const DIV_RESULT$ = "<div class=""result-container"">"
    URL = URL_TEMPLATE & URLEncode(SText)
    URL = Replace(URL, "[to]", ToLang)
    URL = Replace(URL, "[from]", FromLang)
    xmlhttp.Open "GET", URL, False
    xmlhttp.Send
    resp = xmlhttp.responseText
    'Debug.Print resp
    p1 = InStr(resp, DIV_RESULT)
    If p1 > 0 Then
        p1 = p1 + Len(DIV_RESULT)
        p2 = InStr(p1, resp, "</div>")
        Translate = Mid(resp, p1, p2 - p1)
    End If
        
End Function

Function URLEncode(ByRef txt As String) As String
    Dim buffer As String, i As Long, c As Long, n As Long
    buffer = String$(Len(txt) * 12, "%")
 
    For i = 1 To Len(txt)
        c = AscW(Mid$(txt, i, 1)) And 65535
 
        Select Case c
            Case 48 To 57, 65 To 90, 97 To 122, 45, 46, 95  ' Unescaped 0-9A-Za-z-._ '
                n = n + 1
                Mid$(buffer, n) = ChrW(c)
            Case Is <= 127            ' Escaped UTF-8 1 bytes U+0000 to U+007F '
                n = n + 3
                Mid$(buffer, n - 1) = Right$(Hex$(256 + c), 2)
            Case Is <= 2047           ' Escaped UTF-8 2 bytes U+0080 to U+07FF '
                n = n + 6
                Mid$(buffer, n - 4) = Hex$(192 + (c \ 64))
                Mid$(buffer, n - 1) = Hex$(128 + (c Mod 64))
            Case 55296 To 57343       ' Escaped UTF-8 4 bytes U+010000 to U+10FFFF '
                i = i + 1
                c = 65536 + (c Mod 1024) * 1024 + (AscW(Mid$(txt, i, 1)) And 1023)
                n = n + 12
                Mid$(buffer, n - 10) = Hex$(240 + (c \ 262144))
                Mid$(buffer, n - 7) = Hex$(128 + ((c \ 4096) Mod 64))
                Mid$(buffer, n - 4) = Hex$(128 + ((c \ 64) Mod 64))
                Mid$(buffer, n - 1) = Hex$(128 + (c Mod 64))
            Case Else                 ' Escaped UTF-8 3 bytes U+0800 to U+FFFF '
                n = n + 9
                Mid$(buffer, n - 7) = Hex$(224 + (c \ 4096))
                Mid$(buffer, n - 4) = Hex$(128 + ((c \ 64) Mod 64))
                Mid$(buffer, n - 1) = Hex$(128 + (c Mod 64))
        End Select
    Next
    URLEncode = Left$(buffer, n)
End Function