fonction google translate utilisable par formule ou VBA

patricktoulon

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

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
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas