XL 2016 Traduction automatique de cellules

Option Explicit
Sub Test3()
   Dim Z As String
   Z = Traduction("Filtre reniflard à charbon actif", EnLang:="en") & vbLf & _
       Traduction("Détecteur de niveau à lames vibrantes", EnLang:="en")
' Fin de l'exemple d'instruction de démo, le reste c'est pour produire le résultat :
   With New MSForms.DataObject: .SetText Z: .PutInClipboard: End With
   MsgBox Z, vbInformation, "Test"
   End Sub
Public Function Traduction(ByVal Texte As String, Optional ByVal DeLang As String = "fr", Optional ByVal EnLang As String = "fr")
Rem. —— Renvoie la traduction d'un texte
'     Texte:  Le texte à traduire
'     DeLang: Code de la langue du texte à traduire. Facultatif: "fr" assumé.
'     EnLang: Code de la langue du texte résultant souhaité. Facultatif: "fr" assumé.
Rem: Ces codes de langues sont en 2 caractères abrégeant en leur propre version le nom de cette langue.
Rem. Très important: N'oubliez pas d'activer les références "Microsoft XML, v6.0" et "Microsoft HTML Object Library"
   Dim SXP As New MSXML2.ServerXMLHTTP, Code As String, HDt As MSHTML.HTMLDocument, Item As Object, DEt As MSHTML.HTMLDivElement
   SXP.Open "POST", "https://translate.google.pl/m?hl=" & DeLang & "&sl=" & DeLang _
      & "&tl=" & EnLang & "&ie=UTF-8&prev=_m&q=" & UHexaTexte(Texte), False
   SXP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
   SXP.send
   Set HDt = New HTMLDocument
   HDt.body.innerHTML = SXP.responseText
   For Each Item In HDt.ALL
      If TypeOf Item Is MSHTML.HTMLDivElement Then
         Set DEt = Item
         If DEt.className = "t0" Then Traduction = DEt.innerText: Exit Function
         End If
      Next Item
   End Function
Private Function UHexaTexte(ByVal Texte As String) As String
Rem. —— Renvoie un texte dont chaque caractères de code ASCII > 127 est remplacé
'     par "\u" suivi du code hexadécimal de 4 de long de ce code ASCII.
   Dim TJn() As String, P As Long, C As String * 1, A As Integer, J As Long
   ReDim TJn(0 To 0)
   For P = 1 To Len(Texte)
      C = Mid$(Texte, P, 1): A = AscW(C)
      If A > 127 Then
         J = J + 1: ReDim Preserve TJn(0 To J)
         TJn(J) = Right$("000" & Hex$(A), 4)
      Else
         TJn(J) = TJn(J) & C
         End If: Next P
   UHexaTexte = Join$(TJn, "\u")
   End Function

Function EncodeGtranslateText(chaine)
     chaine2 = Replace(chaine, "'", "%27")
    For P = 1 To Len(chaine)
        C = Mid$(chaine, P, 1): A = AscW(C)
        If A > 127 Then chaine2 = Replace(chaine2, C, "%C3%A" & Replace(CStr(Hex$(A)), "E", ""))
    Next
    EncodeGtranslateText = Replace(chaine2, Chr(160), "+")
End Function

Public Function Translate(Optional texte As String, Optional From As String = "en", Optional ToLang As String = "fr", Optional urlI As String)
    Dim RQ As Object, URL As String, code As String, elem As Object, X As Long
    't1 = "âÄàéèéèêëiîôùûü": t2 = "aAaeeeeeeiIoouuu"
    'For i = 1 To Len(t1): texte = Replace(texte, Mid(t1, i, 1), Mid(t2, i, 1)): Next
    texte = EncodeGtranslateText(texte)
    Set RQ = CreateObject("microsoft.xmlhttp")    '"MSXML2.ServerXMLHTTP"
    If urlI <> "" Then
        URL = urlI
    Else
        URL = "https://translate.google.pl/m?hl=" & From & "&sl=" & From & "&tl=" & ToLang & "&ie=UTF-8&prev=_m&q=" & texte
    End If
    RQ.Open "POST", URL, False
    RQ.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    RQ.send
    With CreateObject("htmlfile")
        .body.innerhtml = RQ.responsetext
        For Each elem In .ALL
            If elem.Tagname = "DIV" And elem.classname = "t0" Then Translate = elem.innerhtml: Exit For
        Next
    End With

End Function

Sub test9()
    MsgBox EncodeGtranslateText("Les élèves vont à l'école.")
End Sub

Option Explicit

Public Function Translate2(Optional SendText As String, Optional From As String = "en", Optional ToLang As String = "fr", Optional Convert = 0)
    Dim RQ As Object, URL$, elem As Object, X&
    Set RQ = CreateObject("microsoft.xmlhttp")    '"MSXML2.ServerXMLHTTP"
    If Convert <> 0 Then If Convert = 1 Then SendText = EncodeText1(SendText) Else SendText = EncodeText2(SendText)
    URL = "https://translate.google.pl/m?hl=" & From & "&sl=" & From & "&tl=" & ToLang & "&ie=UTF-8&prev=_m&q=" & SendText
    RQ.Open "POST", URL, False
    RQ.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    RQ.send
    With CreateObject("htmlfile")
        .body.innerhtml = RQ.responsetext
        For Each elem In .ALL
            If elem.Tagname = "DIV" And elem.classname = "t0" Then Translate2 = elem.innerhtml: Exit For
        Next
    End With
End Function
'---------------------------------------------------------------------------------------------------------
Function EncodeText1(chaine) As String
Dim t1, t2, i&
    t1 = "âÄàéèéèêëiîôùûü": t2 = "aAaeeeeeeiIoouuu"
    For i = 1 To Len(t1): chaine = Replace(chaine, Mid(t1, i, 1), Mid(t2, i, 1)): Next
   EncodeText1 = chaine
End Function
'---------------------------------------------------------------------------------------------------------
Function EncodeText2(chaine) As String    'sur la base Dranreb exceldownload
    Dim chaine2$, P&, C$, A&
    chaine2 = Replace(chaine, "'", "%27")
    For P = 1 To Len(chaine)
       C = Mid$(chaine, P, 1): A = AscW(C)
        If A > 127 Then chaine2 = Replace(chaine2, C, "\u" & Right$("000" & LCase$(Hex$(A)), 4))
    Next
    EncodeText2 = chaine2
End Function
'---------------------------------------------------------------------------------------------------------
Function DecodeText2(ByVal Txt As String) As String    'sur la base Dranreb exceldownload
   Dim TJn() As String, J As Long
   TJn = Split(Txt, "\u")
   DecodeText2 = Replace(Txt, "%27", "'")
   For J = 1 To UBound(TJn):
        DecodeText2 = Replace(DecodeText2, "\u" & Left$(TJn(J), 4), ChrW$(Val("&H" & Left$(TJn(J), 4))))
   Next J
End Function
'---------------------------------------------------------------------------------------------------------
Sub test()
   'utilisation sequencée
    MsgBox Translate2(EncodeText1("Les élèves vont à l'école."), "fr", "en") & vbCrLf & _
           Translate2(EncodeText2("Les élèves vont à l'école."), "fr", "en")

'utilisation compact vba et formule
MsgBox Translate2("Les élèves vont à l'école.", "fr", "en", 1)
MsgBox Translate2("Les élèves vont à l'école.", "fr", "en", 2)

'************************************************************
'formule BASE                                               *
'=Translate(A1;"fr";"en";2)'conversion hexa                 *
'=Translate(A1;"fr";"en";1)'conversion by replacements      *
'************************************************************
End Sub