[VBA][Excel] Translate selected cell with Google Translate.

GGTranslateExcel.vba

Dim LangID
Dim MacroUndo() As Variant
Dim MacroUndo2 As Variant
Public Declare PtrSafe Function InternetGetConnectedState Lib "wininet.dll" ( _
    ByRef lpdwFlags As Long, _
    ByVal dwReserved As Long) _
    As Boolean

Public Function IsInternetOnline() As Boolean
    Dim lConnectionFlag As Long
    If InternetGetConnectedState(lConnectionFlag, 0) Then
        IsInternetOnline = True
    Else
        IsInternetOnline = False
    End If
End Function

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 v6.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

Private 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

Sub TranslateThaiNow()
'Translate active cell to Thai immediately
Dim cell As Range, LangUI(2) As String
LangID = Application.International(xlCountryCode)

Select Case LangID
    Case 66
        LangUI(0) = "ยกเลิกการแปลภาษาเป็นไทย"
        LangUI(1) = "ไม่มีการเชื่อมต่ออินเทอร์เน็ค!" & vbCrLf & "โปรดตรวจสอบสถานะอินเทอร์เน็ตก่อนใช้งาน"
        LangUI(2) = "ผิดพลาด!"
    Case Else
        LangUI(0) = "Undo translate to Thai"
        LangUI(1) = "No Internet connection!" & vbCrLf & "Please check the status of internet connection before use."
        LangUI(2) = "Error!"
End Select

If TypeOf Selection Is Excel.Range Then
    If IsInternetOnline = True Then
        'For Undo event
        Erase MacroUndo()
        If IsArray(Selection) = True Then
            MacroUndo = Range(Selection.Address(0, 0)) 'Multiple cells
        Else
            MacroUndo2 = Selection.Value 'Single cell
        End If
        For Each cell In Range(Selection.Address(0, 0))
            cell.Value = Translate(cell.Value)
        Next
    Else
        MsgBox LangUI(1), vbCritical + vbOKOnly, LangUI(2)
        Exit Sub
    End If
Else
    Debug.Print TypeName(Selection)
End If
If IsArray(Selection) = True Then
    Application.OnUndo text:=LangUI(0), Procedure:="UndoSub" 'Multiple cells
Else
    Application.OnUndo text:=LangUI(0), Procedure:="UndoSub2" 'Single cell
End If
End Sub

Private Sub UndoSub()
'Undo Range
If TypeOf Selection Is Excel.Range Then
    Debug.Print TypeName(Selection)
    Selection = MacroUndo()
Else
    Debug.Print TypeName(Selection)
End If

End Sub
Private Sub UndoSub2()
'Undo cell
If TypeOf Selection Is Excel.Range Then
    Debug.Print TypeName(Selection)
    Selection.Value = MacroUndo2
Else
    Debug.Print TypeName(Selection)
End If

End Sub

Sub TranslateEngNow()
'Translate active cell to English immediately
Dim cell As Range, LangUI(2) As String
LangID = Application.International(xlCountryCode)

Select Case LangID
    Case 66
        LangUI(0) = "ยกเลิกการแปลภาษาเป็นอังกฤษ"
        LangUI(1) = "ไม่มีการเชื่อมต่ออินเทอร์เน็ค!" & vbCrLf & "โปรดตรวจสอบสถานะอินเทอร์เน็ตก่อนใช้งาน"
        LangUI(2) = "ผิดพลาด!"
    Case Else
        LangUI(0) = "Undo translate to English"
        LangUI(1) = "No Internet connection!" & vbCrLf & "Please check the status of internet connection before use."
        LangUI(2) = "Error!"
End Select

If TypeOf Selection Is Excel.Range Then
    If IsInternetOnline = True Then
        'For Undo event
        Erase MacroUndo()
        If IsArray(Selection) = True Then
            MacroUndo = Range(Selection.Address(0, 0)) 'Multiple cells
        Else
            MacroUndo2 = Selection.Value 'Single cell
        End If
        For Each cell In Range(Selection.Address(0, 0))
            cell.Value = Translate(cell.Value, , "en")
        Next
    Else
        MsgBox LangUI(1), vbCritical + vbOKOnly, LangUI(2)
        Exit Sub
    End If
Else
    Debug.Print TypeName(Selection)
End If
If IsArray(Selection) = True Then
    Application.OnUndo text:=LangUI(0), Procedure:="UndoSub" 'Multiple cells
Else
    Application.OnUndo text:=LangUI(0), Procedure:="UndoSub2" 'Single cell
End If
End Sub

Sub TranslateThaiNote()
'Translate active cell to Thai immediately
Dim cell As Range, LangUI(2) As String
LangID = Application.International(xlCountryCode)

Select Case LangID
    Case 66
        LangUI(0) = "ยกเลิกการแปลภาษาเป็นไทย"
        LangUI(1) = "ไม่มีการเชื่อมต่ออินเทอร์เน็ค!" & vbCrLf & "โปรดตรวจสอบสถานะอินเทอร์เน็ตก่อนใช้งาน"
        LangUI(2) = "ผิดพลาด!"
    Case Else
        LangUI(0) = "Undo translate to Thai"
        LangUI(1) = "No Internet connection!" & vbCrLf & "Please check the status of internet connection before use."
        LangUI(2) = "Error!"
End Select

If TypeOf Selection Is Excel.Range Then
    If IsInternetOnline = True Then
        For Each cell In Range(Selection.Address(0, 0))
            With cell
                If Not .Comment Is Nothing Then .Comment.Delete
                .AddComment
                .Comment.text Translate(.Value)
                .Comment.Shape.TextFrame.AutoSize = True
            End With
        Next
    Else
        MsgBox LangUI(1), vbCritical + vbOKOnly, LangUI(2)
        Exit Sub
    End If
Else
    Debug.Print TypeName(Selection)
End If
End Sub

Sub TranslateEngNote()
'Translate active cell to English immediately
Dim cell As Range, LangUI(2) As String
LangID = Application.International(xlCountryCode)

Select Case LangID
    Case 66
        LangUI(0) = "ยกเลิกการแปลภาษาเป็นอังกฤษ"
        LangUI(1) = "ไม่มีการเชื่อมต่ออินเทอร์เน็ค!" & vbCrLf & "โปรดตรวจสอบสถานะอินเทอร์เน็ตก่อนใช้งาน"
        LangUI(2) = "ผิดพลาด!"
    Case Else
        LangUI(0) = "Undo translate to English"
        LangUI(1) = "No Internet connection!" & vbCrLf & "Please check the status of internet connection before use."
        LangUI(2) = "Error!"
End Select

If TypeOf Selection Is Excel.Range Then
    If IsInternetOnline = True Then
        For Each cell In Range(Selection.Address(0, 0))
            With cell
                If Not .Comment Is Nothing Then .Comment.Delete
                .AddComment
                .Comment.text Translate(.Value, , "en")
                .Comment.Shape.TextFrame.AutoSize = True
            End With
        Next
    Else
        MsgBox LangUI(1), vbCritical + vbOKOnly, LangUI(2)
        Exit Sub
    End If
Else
    Debug.Print TypeName(Selection)
End If
End Sub