XL 2016 Traduction automatique de cellules

josesamdc

XLDnaute Nouveau
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.
 

Fichiers joints

patricktoulon

XLDnaute Impliqué
bonjour
ca n'existe pas nativement du moins pas a ma connaissance
il te faut créer une fonction pilotée par formule

je te donne ma fonction perso
VB:
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
exemple de formule par exemple en B4 dans ton fichier
=SI(A4<>"";Translate(A4;"fr";"en");"")
il te reste plus qu'a étendre la formule
ajouter peut etre la condition

la requête est effectuée sur la version mobile de google translate (ancienne version pc en fait très épurée )ce qui la rend très rapide (normalement )
demo3.gif
 

josesamdc

XLDnaute Nouveau
Merci ça fonctionne impeccable, mais il faut quand même installer la fonction "TRANSLATE" (.msi) si non cela fonctionne pas.
 

patricktoulon

XLDnaute Impliqué
bonjour Dranreb
mais la ca fait appel a une base
la mienne est dynamique avec google translate ce qui fait que ça te traduit ce que tu veux
bon des fois google déraille mais bon dans l'ensemble c'est correct

demo3.gif
 

josesamdc

XLDnaute Nouveau
Bonjour,
Le traducteur fonctionne mais il ne reconnait pas les accents il met "?".
Il ne tien pas compte des caractères il met rien à la place.
Pourtant avec cette macro on est dirigé vers https://translate.google.pl/ qui lui prend en compte les caractères et accents en français.
 

Dranreb

XLDnaute Barbatruc
Bonjour.
À tout hasard, essayez en introduisant, là où il faudrait peut être, une utilisation de ces fonctions :
VB:
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
 
Dernière édition:

Dranreb

XLDnaute Barbatruc
Fonction TxtCodé rectifiée pour ne pas risquer de louper certains caractères :
VB:
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
A
Un texte bien de chez nous
(Constante texte)
B
Language XML
=TxtCodé(A1)
C
Retraduit en clair
=TxtClair(B1)
1​
Île-de-France\u00cele-de-FranceÎle-de-France
2​
Joyeux NoëlJoyeux No\u00eblJoyeux Noël
3​
La charrue avant les bœufsLa charrue avant les b\u0153ufsLa charrue avant les bœufs
4​
ç'en est trop\u00e7'en est tropç'en est trop
5​
LætitiaL\u00e6titiaLætitia
 
Dernière édition:

josesamdc

XLDnaute Nouveau
Fonction TxtCodé rectifiée pour ne pas risquer de louper certains caractères :
VB:
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
A
Un texte bien de chez nous
(Constante texte)
B
Language XML
=TxtCodé(A1)
C
Retraduit en clair
=TxtClair(B1)
1​
Île-de-France\u00cele-de-FranceÎle-de-France
2​
Joyeux NoëlJoyeux No\u00eblJoyeux Noël
3​
La charrue avant les bœufsLa charrue avant les b\u0153ufsLa charrue avant les bœufs
4​
ç'en est trop\u00e7'en est tropç'en est trop
5​
LætitiaL\u00e6titiaLætitia
Cette fonction ne change rien a moins que je l'ai mal collé.
En tout cas je n'ai pas de bogage.

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

patricktoulon

XLDnaute Impliqué
re
ne t’embête pas fait péter les accents
VB:
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
je le répète c'est la version pour mobile, il s'attends donc a ce que l'argument de la requete dans "q" soit smsisé ;)
j'aurais du le mettre tout de suite
 
Dernière édition:

Dranreb

XLDnaute Barbatruc
Cette fonction ne change rien a moins que je l'ai mal collé.
Mais… vous ne les avez pas du tout utilisées dans votre Function Translate, pour transformer vos textes dans un sens puis dans l'autre !
Genre : URL = "http s://translate … tout ça, tout ça … & TxtCodé(texte) puis plus loin .body.innerhtml = TxtClair(RQ.responsetext)

Je vous signale que j'ai un classeur où je récupère d'une consultation d'un autre site une propriété ResponseText d'objet MSXML2.XMLHTTP qui contient à un certain endroit "75, Paris, \u00cele-de-France" qui se traduit par "75, Paris, Île-de-France" avec ma fonction TxtClair.
Donc dans ce sens c'est pratiquement sûr qu'il le faut. Mais pour soumettre un texte à la traduction je pense qu'il faut aussi faire le codage inverse avec TxtCodé.
 
Dernière édition:

Dranreb

XLDnaute Barbatruc
J'ai fait quelques essais avec la fonction Translate de patricktoulon telle qu'elle est.
Je déteste utiliser un code dont je n'ai aucune idée de comment il fonctionne, mais puisqu'il marche …
Il s'avère que ça semble être seulement à la soumission qu'il faut convertir les caractères de code ASCII > 127.
Le résultat en français est directement avec les lettres accentuées.
VB:
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
Cette Sub Test affiche après envoi dans le presse papier ce que je colle ici :
nothing ? see
nothing to see
rien à voir
 
Dernière édition:

Dranreb

XLDnaute Barbatruc
Une autre :
VB:
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
The students go? the? cole.
The students are going to the school.
Curieux qu'il comprenne quand même le mot "élèves" non traité. Peut être déduit-il d'une recherche en trouvant qu'il n'y a que ce mot qui soit de la forme ?l?ves …
Hé ouais c'est ça: si le remplace les "é" et "è" par de vrais points d'interrogation, il comprend quand même students !
 
Dernière édition:

patricktoulon

XLDnaute Impliqué
Bonjour dranreb
intéressant ton truc

et effectivement c'est a la soumission de la chaîne a translate que les accents foutent le boxon
perso je remplace les accentués par les même caractères sans accents
sinon il faut respecter la construction de l'url avec les 020% pour les espaces etc.....

pour info la requete enregistré me donne
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
 
Dernière édition:

Dranreb

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

XLDnaute Barbatruc
Sinon voici un code complet commençant par une procédure Test3 pour montrer un exemple d'utilisation :
VB:
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.
 
Dernière édition:

patricktoulon

XLDnaute Impliqué
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

XLDnaute Impliqué
re
du coup tu m'a donné la solution
VB:
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

Code:
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
Code:
Sub test9()
    MsgBox EncodeGtranslateText("Les élèves vont à l'école.")
End Sub
 

josesamdc

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

Discussions similaires


Haut Bas