XL 2016 VBA - Fonction traduction, accès refusé

Remteyss

XLDnaute Junior
Bonjour le forum,

Dans une macro, j'utilise la fonction traduction ci-dessous :
VB:
Public Function Translate(Optional texte As String, Optional From As String, Optional ToLang As String, 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?&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)"
[B]    RQ.send[/B]
    With CreateObject("htmlfile")
        .body.innerhtml = RQ.responsetext
        Debug.Print Replace(RQ.responsetext, "<>", ">" & vbCrLf & "<")
        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 l'ai testée hier et ça fonctionnait puis après l'avoir relancée une seconde fois, elle ne marchait plus. Ce matin, je rallume mon ordi et ça refonctionne puis la seconde, troisième, quatrième... fois elle ne marche plus. Voici le message d'erreur que je rencontre :
1596543992047.png

La ligne que j'ai mise en gras dans le code est celle surlignée par le débogueur.
N'ayant j'avais utilisé CreateObject je ne vois pas du tout quel est le problème, si vous avez des idées :)

Merci !
 

patricktoulon

XLDnaute Barbatruc
re
tiens la version simplifiée avec en prime le convertisseur encode url
VB:
Option Explicit
'************************************************************
    'formule BASE                                               *
    '=Translate2(A1;"fr";"en";2)'conversion hexa                *
 '***********************************************************
Sub test()
MsgBox Translate2("bonjour tout le monde", "fr", "en", 2)
End Sub
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 EncodeText2(ByVal Texte As String) As String
    Dim P&, C$, A&
    For P = 1 To Len(Texte)
        C = Mid$(Texte, P, 1): A = AscW(C)
        Select Case A
        'Case 32: C = "+"'pour ceux qui préfèrent "+" au lieu de "%20"
        Case Is > 127: C = "\u" & Right$("000" & Hex$(A), 4)
        Case 0 To 44, 47, 58 To 64, 91 To 94, 96, 123 To 127: C = "%" & Right$("0" & Hex$(A), 2)
        End Select
        EncodeText2 = EncodeText2 & C
    Next P
End Function
 

patricktoulon

XLDnaute Barbatruc
Dernière édition:

Remteyss

XLDnaute Junior
re
encodetext2
ça ré encode les caractères spéciaux au format hexa de l'url
la 1 je te l'ai pas donné elle est moins au point
ainsi ceci
https://translate.google.pl/m?hl=fr&sl=fr&tl=en&ie=UTF-8&prev=_m&q=Les élèves vont à l'école.

devient cela
https://translate.google.pl/m?hl=fr&sl=fr&tl=en&ie=UTF-8&prev=_m&q=Les%20\u00E9l\u00E8ves%20vont%20\u00E0%20l%27\u00E9cole

on pourait voir le texte de cette case que tu veux traduire ?

Bonjour @patricktoulon
Oui mais dans la fonction Translate2 il y a cette ligne :
VB:
If Convert <> 0 Then If Convert = 1 Then SendText = EncodeText1(SendText) Else SendText = EncodeText2(SendText)
Il faut en fait lire EncodeText2 donc ?

C'est un fichier très volumineux que je ne peux malheureusement pas diffusé.

En fait, je ne pense pas que cela soit dû à une case en particulier. Ce matin le problème vient du fait que la fonction ne traduit plus, du moins elle considère la variable texte égale à "" puisque lorsque j'exécute ta procédure :
Code:
Sub test()
    MsgBox Translate2("bonjour tout le monde", "fr", "en", 2)
End Sub

j'obtiens :
1596620694803.png


Y aurait-il des lignes de code à ajouter au préalable avant d'utiliser la fonction CreateObject ?
 

patricktoulon

XLDnaute Barbatruc
tu n'avais pas besoins de l'activer c'est en late binding "createobject......"
tu peux activer ce que tu veux si elles sont fracca elles sont fracca
et là je peux rien pour toi désolé
soit une réparation d'office fera l'affaire soit c'est ton windows qui faut ré imager
 

Remteyss

XLDnaute Junior
Bonjour,

Je suis enfin parvenu à la traduction que j'attendais ! Mais bon qu'une seule fois, les autres fois ça m'arrivait même de demander une traduction vers l'allemand et j'obtenais du français...
J'attends donc l'intervention du service info et en attendant j'ai une petite question ; J'ai la version Excel 32 bits mais mon PC est en 64 bits. Je sais que dans ce sens ça ne devrait pas poser de soucis mais est-ce que vous pensez que cela pourrait éventuellement être une cause de mon problème ?
 
Haut Bas