Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2019 translateAddin ne marche pas

lamho27

XLDnaute Occasionnel
Bonjour le forum

J’ai un problème addin translate ne marche pas si j’ai activé « Protection contre les virus et menaces »

Pouvez-vous me corriger ce problème

Merci d’avance

Global myRibbon As IRibbonUI
Global fromLanguageCode As String
Global toLanguageCode As String
Sub Onload(ribbon As IRibbonUI)
Set myRibbon = ribbon
End Sub
Sub GetFromItemCount(ByVal control As IRibbonControl, ByRef count)
Application.OnKey "+^T", "TranslateRanges"
count = UBound(GetLanguages) - LBound(GetLanguages) + 1
End Sub
Sub GetFromItemLabel(ByVal control As IRibbonControl, index As Integer, ByRef label)
label = GetLanguages()(index)
End Sub
Sub GetFromSelectedItemIndex(ByVal control As IRibbonControl, ByRef index)
End Sub
Sub InsertFromLanguage(ByVal control As IRibbonControl, selectedID As String, selectedIndex As Integer)
fromLanguageCode = GetLanguageCode(CLng(selectedIndex))
End Sub
Sub GetToItemCount(ByVal control As IRibbonControl, ByRef count)
count = UBound(GetLanguages) - LBound(GetLanguages) + 1
End Sub
Sub GetToItemLabel(ByVal control As IRibbonControl, index As Integer, ByRef label)
label = GetLanguages()(index)
End Sub
Sub GetToSelectedItemIndex(ByVal control As IRibbonControl, ByRef index)
End Sub
Sub InsertToLanguage(ByVal control As IRibbonControl, selectedID As String, selectedIndex As Integer)
toLanguageCode = GetLanguageCode(CLng(selectedIndex))
End Sub
Sub Translate(control As IRibbonControl)
TranslateRanges
End Sub
Public Sub TranslateRanges()
Dim r As Range
For Each r In Selection
r.Value = TranslateText(r.Value, fromLanguageCode, toLanguageCode)
Next r
End Sub
Function GetLanguages() As String()
Dim languages As String
languages = "Afrikaans|Albanian|Arabic|Azerbaijani|Basque|Belarusian|Bengali|Bulgarian|Catalan|Chinese_Simplified|Chinese_Traditional|Croatian|Czech|Danish|Dutch|English|Esperanto|Estonian|Filipino|Finnish|French|Galician|Georgian|German|Greek|Gujarati|Haitian_Creole|Hebrew|Hindi|Hungarian|Icelandic|Indonesian|Irish|Italian|Japanese|Kannada|Korean|Latin|Latvian|Lithuanian|Macedonian|Malay|Maltese|Norwegian|Persian|Polish|Portuguese|Romanian|Russian|Serbian|Slovak|Slovenian|Spanish|Swahili|Swedish|Tamil|Telugu|Thai|Turkish|Ukrainian|Urdu|Vietnamese|Welsh|Yiddish"
GetLanguages = Split(languages, "|")
End Function
Function GetLanguageCode(index As Long) As String
Dim languages As String
languages = "af|sq|ar|az|eu|be|bn|bg|ca|zh-cn|zh-TW|hr|cs|da|nl|en|eo|et|tl|fi|fr|gl|ka|de|el|gu|ht|iw|hi|hu|is|id|ga|it|ja|kn|ko|la|lv|lt|mk|ms|mt|no|fa|pl|pt|ro|ru|sr|sk|sl|es|sw|sv|ta|te|th|tr|uk|ur|vi|cy|yi"
GetLanguageCode = Split(languages, "|")(index)
End Function
Function TranslateText(str As String, translateFrom As String, translateTo As String) As String
If str = "" Or str = vbNullString Or Trim(str) = "" Or Trim(str) = vbNullString Then
TranslateText = str
Exit Function
End If
Dim getParam As String, trans As String
Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
getParam = ConvertToGet(str)
URL = "https://translate.google.pl/m?hl=" & translateFrom & "&sl=" & translateFrom & "&tl=" & translateTo & "&ie=UTF-8&prev=_m&q=" & getParam
objHTTP.Open "GET", URL, False
objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
objHTTP.send ("")
If InStr(objHTTP.responseText, "div dir=""ltr""") > 0 Then
trans = RegexExecuteGet(objHTTP.responseText, "div[^""]*?""ltr"".*?>(.+?)</div>", 0, 0)
TranslateText = Clean(trans)
Else
Err.Raise 0, "Translate", "No connection or other error"
End If
End Function
Private Function ConvertToGet(val As String)
val = Replace(val, " ", "+")
val = Replace(val, vbNewLine, "+")
val = Replace(val, "(", "%28")
val = Replace(val, ")", "%29")
ConvertToGet = val
End Function
Private Function Clean(val As String)
val = Replace(val, "&quot;", """")
val = Replace(val, "%2C", ",")
val = Replace(val, "&#39;", "'")
Clean = val
End Function
Function RegexExecuteGet(str As String, reg As String, Optional matchIndex As Long = 0, Optional subMatchIndex As Long = 0) As String
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp"): regex.Pattern = reg
regex.Global = Not (matchIndex = 0 And subMatchIndex = 0) 'For efficiency
If regex.Test(str) Then
Set matches = regex.Execute(str)
RegexExecuteGet = matches(matchIndex).SubMatches(subMatchIndex)
Exit Function
End If
End Function
 

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…