XL 2016 Traduction automatique de cellules

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

Function TxtCodé(ByVal TxtClair As String) As String
   Const LetAcc = "àâéèêëiîôùûü"
   Dim P As Long, C As String * 1
   TxtCodé = TxtClair
   For P = 1 To Len(LetAcc)
      C = Mid$(LetAcc, P, 1): TxtCodé = Replace$(TxtCodé, C, "\u" & Right$("0000" & LCase$(Hex$(AscW(C))), 4))
      C = UCase$(C):          TxtCodé = Replace$(TxtCodé, C, "\u" & Right$("0000" & LCase$(Hex$(AscW(C))), 4))
      Next P
   End Function
Function TxtClair(ByVal TxtCodé As String) As String
   Dim TSpl() As String, P As Long
   TSpl = Split(TxtCodé, "\u")
   For P = 1 To UBound(TSpl): TSpl(P) = ChrW$(Val("&H" & Left$(TSpl(P), 4))) & Mid$(TSpl(P), 5): Next P
   TxtClair = Join(TSpl, "")
   End Function

Function TxtCodé(ByVal TxtClair As String) As String
   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(TxtClair)
      C = Mid$(TxtClair, P, 1): A = AscW(C)
      If A > 127 Then
         J = J + 1: ReDim Preserve TJn(0 To J)
         TJn(J) = Right$("000" & LCase$(Hex$(A)), 4)
      Else
         TJn(J) = TJn(J) & C
         End If: Next P
   TxtCodé = Join$(TJn, "\u")
   End Function
Function TxtClair(ByVal TxtCodé As String) As String
   Dim TJn() As String, J As Long
   TJn = Split(TxtCodé, "\u")
   For J = 1 To UBound(TJn): TJn(J) = ChrW$(Val("&H" & Left$(TJn(J), 4))) & Mid$(TJn(J), 5): Next J
   TxtClair = Join$(TJn, "")
   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
    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 Test()
   Dim Z As String
   Z = Translate("rien à voir", "fr", "en") _
      & vbLf & Translate(UHexaTexte("rien à voir"), "fr", "en") _
      & vbLf & Translate("nothing to see", "en", "fr")
   With New MSForms.DataObject: .SetText Z: .PutInClipboard: End With
   MsgBox Z, vbInformation, "Test"
   End Sub
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 TexteUHexa(ByVal UHexa As String) As String
Rem. —— Renvoie un texte dont chaque groupe "\u" suivi d'un code ascii hexadécimal
' de 4 de long est remplacé par le caractère correspondant.
   Dim TJn() As String, J As Long
   TJn = Split(UHexa, "\u")
   For J = 1 To UBound(TJn): TJn(J) = ChrW$(Val("&H" & Left$(TJn(J), 4))) & Mid$(TJn(J), 5): Next J
   TexteUHexa = Join$(TJn, "")
   End Function

Sub Test2()
   Dim Z As String
   Z = Translate("Les élèves vont à l'école.", "fr", "en") _
      & vbLf & Translate(UHexaTexte("Les élèves vont à l'école."), "fr", "en")
   With New MSForms.DataObject: .SetText Z: .PutInClipboard: End With
   MsgBox Z, vbInformation, "Test"
   End Sub