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.
 

Pièces jointes

  • Test.xlsx
    17.1 KB · Affichages: 45

patricktoulon

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

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

Discussions similaires