XL 2016 Traduction automatique de cellules

[josesamdc]

Bonjour,

Je recherche une fonction qui traduise des cellules en automatique sur Excel 2016.
J'ai cherché un peut dans ce forum et je n'ai rien trouvé qui me convenais.


Voir le fichier joint.

 

[Dranreb]

Bonjour.

Cette fonction ne change rien a moins que je l'ai mal collé.

En tout cas vous savez maintenant ce qu'il vous reste à faire pour que vos lettres accentuées soient acceptées, comme il va de soi qu'elles doivent l'être pour un fonctionnement sérieux.

 

[Dranreb]

Sinon voici un code complet commençant par une procédure Test3 pour montrer un exemple d'utilisation :

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

Breather filter with activated charcoal
Level detector with vibrating blades

Cela dit ça m'a toujours l'air d'un monstrueux bordel tout ce qui touche de près ou de loin à internet !
Pour certains trucs existants, il est purement et simplement impossible d'avoir une programmation propre en liaisons anticipées. On est obligé de tous se réécrire différemment pour l'avoir en Dictionary imbriqués, par exemple.

 

[patricktoulon]

re
bonjour dranreb
ce qui est troublant c'est la codification des caractères chez translate par rapport a une codification exa qui est différente

par contre on retrouve les nombres base dans leurs codifications que l'on retrouves avec la codification exa

Clé Valeur
Demande GET /m?hl=fr&sl=fr&tl=en&ie=UTF-8&prev=_m&q=Les+%C3%A9l%C3%A8ves+vont+%C3%A0+l%27%C3%A9cole.%22 HTTP/1.1

Les \u00e9l\u00e8ves vont \u00e0 l'\u00e9cole.

donc attention au nombre de formule(de cellules a traduire) car google a la fâcheuse tendance avec translate ou map de virer les requêtes trop nombreuses qui seraient pas conforme et donc boucler sur une cellule indéfiniment au bout de 10 ou 20 ou 100 selon le trafic aussi
je dis ça car ça m'est déjà arrivé

en remplaçant simplement les caractères par les mêmes sans accents je n'ai a ce jour plus eu de problème et je parle de centaine de lignes


Répondre

 

[patricktoulon]

re
du coup tu m'a donné la solution

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

 

[josesamdc]

Pour le accentuation cette fonction <<t1 = "âÄàéèéèêëiîôùûü": t2 = "aAaeeeeeeiIoouu">> fonctionne.
Mais le caractère (+) peut-être d'autre ça fonctionne pas.

 

[patricktoulon]

re
petite question

c'est quoi la meilleur traduction en prenant en compte le temps de conjugaison
Les élèves vont à l'école.
The students are going to school.
The students go to school.

ps: les "+" c'est pas grave visiblement on peut laisser les espaces

 

[Dranreb]

Avec ma conversion tout fonctionne, non ? Et au moins les lettres accentuées sont analysées.

 

[Dranreb]

Je l'ai installé dans mon classeur dédié à ce genre d'opérations.

 

[patricktoulon]

bonjour dranreb
perso je suis resté en late binding justement parce que le classeur peut être utilisé dans plusieurs PCs
et tout le monde ne sais aller chercher les références

et "microsoft.xmlhttp" est valable de XP à W10(testé)

quand aux variables dimées proprement sache que cette version de translate a subie 2 modifications majeures en 2017 quand translate est passée en app web et 1 en 2018 le vocal a été supprimé littéralement de cette version

avant c’était pas un div et pas cette classe
tu n'est pas a l'abri que ca change a nouveau
donc perso "as object"

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

et pour info

je te laisse donc choisir quelle est la bonne traduction

PS: je pique l'adresse pour le gps je vais me faire mon propre truc

en plus c'est mieux que gmap car même si l'expression est pas complète ou mal orthographié ça match quand même
je cherche a tester "&limite=X" plus de 1 pour voir
+++

 

[feuillacdu38]

Bonjour je viens de passer sur cette page et votre code est vraiment intérréssant mais bug à un moment pour moi en évocant une erreur 429 et je ne my connais pas assez pour trouver l'erreur. Voici a ligne indiquée :
Set RQ = CreateObject("microsoft.xmlhttp") '"MSXML2.ServerXMLHTTP"

Mon but étant de traduire différentes cellules avec des langages différents à chaque fois (francais, espagnol, italien, norvégien, ...) en anglais

 

[josesamdc]

Bonjour,

Depuis que j'ai migré vers Win10 avec Excel 2016, cela ne fonctionne plus la traduction.
Je n'avais aucun soucis sur Win7 avec le même Excel 2016.
Pourtant je n'ai rien changé.

Avez-vous une solution à m'apporter ?