fonction google translate utilisable par formule ou VBA

patricktoulon

XLDnaute Barbatruc
[FONCTION OBSOLETE] VOIR ici
Bonjour a tous
je vous propose cette petite fonction de traduction utilisant google translate Mobile

j'ai repris l'idée de Dranreb pour la conversion des caractères spéciaux
et une autre qui remplace les caracteres par les mêmes sans accents
VB:
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
    Debug.Print URL
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), CStr(Mid(t2, i, 1))): Next
    EncodeText1 = Replace(chaine, " ", "+")
End Function
'---------------------------------------------------------------------------------------------------------
Function EncodeText2(chaine) As String    'sur la base Dranreb exceldownload
    Dim chaine2$, P&, c$, A&
    chaine2 = chaine
    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))
       ElseIf A = 32 Then
            chaine2 = Replace(chaine2, c, "+")
        ElseIf A = 39 Then chaine2 = Replace(chaine2, c, "%" & Hex$(A))
        End If
    Next
    EncodeText2 = chaine2
End Function

la sub pour tester
Code:
'---------------------------------------------------------------------------------------------------------
Sub test()
'utilisation séquencé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)


End Sub

les formules de base
'formule BASE *
=Translate2(A1;"fr";"en";2) pour encodetext2 conversion hexa
'=Translate2(A1;"fr";"en";1) pour encodetext1 conversion by replacements
'************************************************************
 
Dernière édition:

Dranreb

XLDnaute Barbatruc
Bonsoir.
J'ai indiqué ici une fonction légèrement plus complète qui, sur les intervalles x = 1 à 31 et 33 à 127, suit mieux la fonction URLENCODAGE(CAR(x)) d'Excel 2013 et suivants.
En dehors des chiffres et des lettres non accentuées, seuls le point, le moins et le blanc souligné ne sont pas transformés. Même la virgule est changée en %2C.
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
bonjour Dranreb
j'ai 2013 et 2007 mais j'utilise le plus souvent 2007 cette fonction ne m'est donc pas abordable
je préfère donc une fonction perso qui elle fonctionnera sur toutes versions excel ;)

quand a ton model "+complet" je n'arrive pas a l'adapter ca me sort n'importe quoi

VB:
Function EncodeText2(chaine) As String    'sur la base Dranreb exceldownload
    Dim chaine2$, P&, c$, cc$, A&
    chaine2 = chaine
    For P = 1 To Len(chaine)
        c = Mid$(chaine, P, 1): A = AscW(c)
       
         Select Case A
         Case 32: cc = "+" ' Worksheetfunction.EncodeURL renvoie "%20", mais bon, si "+" passe, c'est pas plus mal.
         Case Is > 127: cc = "\u" & Right$("000" & Hex$(A), 4) ' Worksheetfunction.EncodeURL renvoie une codification incompréhensible.
         Case 0 To 44, 47, 58 To 64, 91 To 94, 96, 123 To 127: cc = "%" & Right$("0" & Hex$(A), 2)
         End Select
     chaine2 = Replace(chaine2, c, cc)
     
       
       
        
    Next
    EncodeText2 = chaine2
End Function

résultat
\u00E9\u00E9\u00E8\u00E8 \u00E8 \u00E0 \u00E9'\u00E9\u00E9 \u00E9\u00E9

et donc le résultat de la requête n'en est pas moins bizarre

sans doute parce que le replace doit remplacer les lettre en hex précédemment remplacées
 

Dranreb

XLDnaute Barbatruc
Il faut évidemment l'appliquer à un texte brut, pas à un qui a déjà subi des transformations, c'est évident.
Et d'ailleurs ce n'est pas ma fonction. La mienne n'a pas de Replace: elle concatène au fûr et à mesure. Arrête de toujours tout refaire à ta sauce qui ne marche jamais :mad: Sinon je vais fini par ignorer tes interventions.
 

patricktoulon

XLDnaute Barbatruc
re
c'est pas une question de sauce c'est une question d'habitude tu a la tienne j'ai la mienne
avec la tienne je ne peux utiliser le replace en effet
Arrête de toujours tout refaire à ta sauce qui ne marche jamais
c'est toi qui le dit et je pourrais en dire autant mais je me le serais jamais permis ;)
au contraire je suis d'autant plus curieux quand les opinions sont opposé au mien
c'est la base pour échange dans un forum quel qu'en soit le thème
 

patricktoulon

XLDnaute Barbatruc
bonjour a tous
petite mise a jour
googletranslatemobile ayant intégré son web app translate idem a google translate
ma fonction est devenu inutilisable
en attendant mieux je vous propose la meme chose mais avec reverso
VB:
'italien:   ita
'anglais:   eng
'allemand:  ger
'espagnol:  spa
Sub test()
    MsgBox translate_In_Out("bonjour a tous sur ExcelDownloads", "fra", "spa")
End Sub

Function translate_In_Out(Texte, Optional LgIn$ = "fra", Optional LgOut$ = "eng")
    Dim req
    Set req = CreateObject("microsoft.xmlhttp")
    URL = "https://api.reverso.net/translate/v1/translation/"
    req.Open "get", URL, False
    req.SetRequestHeader "Accept", "application/json, text/javascript, */*; q=0.01"
    req.SetRequestHeader "Content-Type", "application/json; charset=utf-8"
    req.SetRequestHeader "Referer", "https://www.reverso.net/translationresults.aspx?lang=FR&direction=francais-anglais"
    req.SetRequestHeader "Accept-Language", "fr-FR"
    req.SetRequestHeader "Origin", "https://www.reverso.net"
    req.SetRequestHeader "Accept-Encoding", "gzip, deflate"
    req.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64; Trident/7.0; rv:11.0) like Gecko/20100101 Firefox/22.0"
    req.SetRequestHeader "Host", "api.reverso.net"
    req.SetRequestHeader "DNT", 1
    req.SetRequestHeader "Connection", "Keep - Alive"
    req.SetRequestHeader "Cache-Control", "no-cache"
    req.send "{""input"":""" & Texte & """,""from"":""" & LgIn & """,""to"":""" & LgOut & """,""format"":""text"",""options"":{""origin"":""reversodesktop"",""sentenceSplitter"":true,""contextResults"":true,""languageDetection"":false}}"
      translate_In_Out = Split(Split(req.responsetext, "translation"":[""")(1), Chr(34))(0)
End Function
;)
 

soan

XLDnaute Barbatruc
Bonjour @patricktoulon, @Dranreb, le fil,

j'ai essayé ton code VBA qui utilise le site reverso,
et j'confirme que ça fonctionne impeccable ! 😊

un grand bravo à toi ! 👍 👏 👏 👏




nota bene : tu as oublié de préciser que ça marche aussi
avec une fonction placée directement sur la feuille :


=translate_In_Out("bonjour a tous sur ExcelDownloads", "fra", "spa")

soan
 

Statistiques des forums

Discussions
287 386
Messages
1 883 244
Membres
162 829
dernier inscrit
aminou3100
Haut Bas