Option Explicit '--------------------------------------------------------------------------------------- ' Module : MSTranslator ' Author : Patrick O'Beirne (@ExcelAnalytics) ' Systems Modelling http://www.sysmod.com ' http://ie.linkedin.com/in/patrickobeirne ' Source : https://sysmod.wordpress.com/2012/01/09/microsoft-translator-vba-code-sample/ 'https://opensource.org/licenses/mit-license.php 'Copyright 2012-2016 Patrick O'Beirne 'Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), _ to deal in the Software without restriction, including without limitation the rights to _ use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, _ and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 'The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 'THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO _ THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. _ IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, _ WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE _ OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 'Contact the author to discuss options for support and Excel/VBA development. ' Date : 10 Jan 2012 ' Updated : 26 July 2012 MS changed order of results ' : 18 May 2015 added Unicode urlescape encoding ' : 10 Jan 2017 added copyright notice and URLDecode for debugging ' Purpose : Functions to use MicrosoftTranslator.com HTTP API ' Usage note: get Client_ID and Secret Token from MS '--------------------------------------------------------------------------------------- 'Sources of info: 'http://msdn.microsoft.com/en-us/library/hh454950.aspx '1) Subscribe: https://datamarket.azure.com/dataset/1899a118-d202-492c-aa16-ba21c33c06cb '2) Register app: '*Client ID fill in any unique ID you want to use later to call for tokens '*Name not used, can be anything '*Client secret supplied by MS, take a note of this '*Redirect URI not used, can be https://localhost if you like 'Description not used, can be anything you like '3) Using the HTTP API: http://msdn.microsoft.com/en-us/library/ff512387.aspx ' list of methods: http://msdn.microsoft.com/en-us/library/ff512419.aspx 'https://social.msdn.microsoft.com/Forums/en-US/home?forum=translatorhub 'Microsoft Translator Hub Feedback and Support has Moved To Uservoice. This Forum is closed. 'translatorbusiness.uservoice.com 'https://translatorbusiness.uservoice.com/knowledgebase/articles/1082224-languages-detected-by-the-detect-method 'Note that Detect may detect languages that Microsoft Translator cannot translate. 'http://docs.microsofttranslator.com/text-translate.html 'https://msdn.microsoft.com/en-us/library/ff512421.aspx 'translate Method ' 'Translates a text string from one language to another. 'REQUEST 'Method Request URI 'GET http://api.microsofttranslator.com/V2/Http.svc/Translate ' 'parameters 'Parameter Description 'appId Required. If the Authorization header is used, leave the appid field empty else a string containing "Bearer" + " " + access token. 'Text Required. A string representing the text to translate. The size of the text must not exceed 10000 characters. 'from Optional. A string representing the language code of the translation text. 'to Required. A string representing the language code to translate the text into. 'contentType Optional. The format of the text being translated. The supported formats are "text/plain" and "text/html". Any HTML needs to be well-formed. 'Category Optional. A string containing the category (domain) of the translation. Defaults to "general". ' 'REQUEST Headers 'The following table describes required and optional request headers. 'Request Header Description 'Authorization 'Required. Specify the the value of access_token in format "Bearer" + " " + Access Token Value ' 'Response 'Return value 'A string representing the translated text. (more...) 'For intellisense, use early binding VBE Tools > References : 'For early binding: Dim As MSXML2.XMLHTTP30 ' Add reference to Microsoft XML, v3.0 ' or Dim As MSXML2.XMLHTTP60 ' Add reference to Microsoft XML, v6.0 'https://blogs.msdn.microsoft.com/xmlteam/2006/10/23/using-the-right-version-of-msxml-in-internet-explorer/ 'Use MSXML 6.0 – it is “in the box” on Vista ... It has the best security, performance, reliability, and W3C conformance 'MSXML 3.0 is our preferred “fallback” 'When you are querying the DOM with SelectNodes or SelectSingleNode the default selection language in MSXML6 is XPath while the default selection language in MSXML3 is XSLPatterns Private Const DEBUG_MODE As Boolean = True ' TESTING Private Const CP_UTF8 = 65001 'MessageBoxW correctly displays international Unicode characters 'WideCharToMultiByte is a Conversion API function for URL encoding as UTF-8 #If VBA7 Then ' Office 2010 or higher, 64-bit Excel compatibility Public Declare PtrSafe Function MessageBoxW Lib "USER32" _ (Optional ByVal hWnd As LongPtr, Optional ByVal Prompt As LongPtr, _ Optional ByVal Caption As LongPtr, Optional ByVal BUTTONS As Long) As Long Private Declare PtrSafe Function WideCharToMultiByte Lib "Kernel32" ( _ ByVal CodePage As LongPtr, ByVal dwflags As LongPtr, _ ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As LongPtr, _ ByVal lpMultiByteStr As LongPtr, ByVal cchMultiByte As LongPtr, _ ByVal lpDefaultChar As LongPtr, ByVal lpUsedDefaultChar As LongPtr) As Long #Else Public Declare Function MessageBoxW Lib "USER32" _ (Optional ByVal hWnd As Long, Optional ByVal Prompt As Long, _ Optional ByVal Caption As Long, Optional ByVal BUTTONS As Long) As Long Private Declare Function WideCharToMultiByte Lib "Kernel32" ( _ ByVal CodePage As Long, ByVal dwflags As Long, _ ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, _ ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, _ ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long #End If Sub testMicrosoftTranslate() 'MsgBox MicrosoftTranslate("Ma déclaration d'impôts", "", "en") ' "My tax return" Dim sTextFrom As String, sLangID As String, sTextTo As String sTextFrom = ActiveCell.Value sLangID = MicrosoftTranslatorDetect(sTextFrom) If DEBUG_MODE Then Debug.Print "Language code: " & sLangID 'ShowMsgBox "Language: " & sLangID _ & vbLf & sText, vbInformation, "MicrosoftTranslatorDetect" 'You may omit the 'From' language code, translator service will detect it 'Here, omitting the 'To' language translates to English. sTextTo = MicrosoftTranslate(sTextFrom, sLangID) ShowMsgBox sTextTo, vbInformation, "MicrosoftTranslate" End Sub Function MicrosoftTranslate(ByVal sText As String, Optional ByVal sLanguageFrom As String = "", Optional ByVal sLanguageTo As String = "en") As String Dim sRequest As String, sResponseText As String If Len(sText) > 0 Then If Len(sText) > 10000 Then If MsgBox("Text is " & Len(sText) & " characters long" _ & vbLf & "Truncate to 10000 characters?", vbOKCancel, "Text exceeds maximum 10,000") = vbOK Then sText = Left$(sText, 10000) Else Exit Function End If End If ' if empty 'From' language, the microsoft translator will detect it automatically sRequest = "Translate?from=" & sLanguageFrom & "&to=" & sLanguageTo & "&text=" If DEBUG_MODE Then Debug.Print sText sResponseText = MSHttpRequest(sRequest, sText) MicrosoftTranslate = StringFromXML(sResponseText) If DEBUG_MODE Then Debug.Print MicrosoftTranslate End If End Function Function MicrosoftTranslatorDetect(sText As String) As String ' returns lowercase two character code eg "fr" MicrosoftTranslatorDetect = MSHttpRequest("Detect?text=", sText) MicrosoftTranslatorDetect = StringFromXML(MicrosoftTranslatorDetect) End Function 'af,ar,bs-Latn,bg,ca,zh-CHS,zh-CHT,yue,hr,cs,da,nl,en,et,fj,fil,fi,fr,de,el,ht,he,hi,mww,hu,id,it,ja,sw,tlh, _ tlh-Qaak,ko,lv,lt,mg,ms,mt,yua,no,otq,fa,pl,pt,ro,ru,sm,sr-Cyrl,sr-Latn,sk,sl,es,sv,ty,th,to,tr,uk,ur,vi,cy Function GetLanguagesForTranslate() As String ' return a simple comma-delimited list from the MS XML GetLanguagesForTranslate = MSHttpRequest("GetLanguagesForTranslate", "") GetLanguagesForTranslate = Replace(GetLanguagesForTranslate, "", ",") GetLanguagesForTranslate = Replace(GetLanguagesForTranslate, "", "") GetLanguagesForTranslate = Mid$(StringFromXML(GetLanguagesForTranslate), 2) ' take off first comma End Function Function MSHttpRequest(ByVal sRequest As String, ByVal sText As String) As String Dim sURL As String, sToken As String, strEncoded As String, bTrying As Boolean strEncoded = URLEncodeUTF8(sText, False, True) ' always encode as UTF-8 sURL = "http://api.microsofttranslator.com/V2/Http.svc/" & sRequest & strEncoded bTrying = True Do While bTrying sToken = GetAccessToken() Dim webRequest As Object Set webRequest = CreateObject("MSXML2.XMLHTTP") 'Dim webRequest As MSXML2.XMLHTTP60 ' Add VBE reference to Microsoft XML, v6.0 'Set webRequest = new MSXML2.XMLHTTP60 webRequest.Open "GET", sURL, False webRequest.setRequestHeader "Authorization", "Bearer " & sToken 'not needed: webRequest.setRequestHeader "Content-Type", "application/x-www-form-urlencoded" webRequest.send MSHttpRequest = webRequest.responseText Set webRequest = Nothing Const HTML_ERR As String = "" ' treat any html as an error message '

TranslateApiException

Method: Translate()

_

Message: Cannot find an active Azure Market Place Translator Subscription associated with the request credentials.

_

message id=0824.V2_Rest.Translate.613D527C

' Could be rate limited. Retry the request. '

Argument Exception

Method: Translate()

Parameter:

_

Message: No bearer information found in the token

'means you did not supply a valid Access Token '

Argument Exception

Method: Translate()

Parameter: from

Message: 'from' must be a valid language _ Parameter name: from

message id=0650.V2_Rest.Translate.502DC8C6

' Translator bug - it will detect "ga-IE" but not allow it as a 'from' language code 'https://msdn.microsoft.com/en-us/library/hh456380.aspx If StrComp(Left$(MSHttpRequest, Len(HTML_ERR)), HTML_ERR, vbTextCompare) = 0 Then Select Case ShowMsgBox(sRequest & vbLf & Left$(MSHttpRequest, 1024), vbExclamation + vbRetryCancel, "Error") Case vbRetry ' keep trying If DEBUG_MODE Then Debug.Print MSHttpRequest: Stop ' to investigate Case vbCancel bTrying = False ' return the HTML. End Select Else bTrying = False ' return the XML End If Loop End Function ' Ensure messagebox appears and disappears properly Function ShowMsgBox(sPrompt As String, lButtons As VbMsgBoxStyle, sTitle As String) As VbMsgBoxResult Dim bScreenUpdating As Boolean bScreenUpdating = Application.ScreenUpdating Application.ScreenUpdating = True ' so msgbox disappears when dismissed DoEvents ShowMsgBox = MessageBoxW(Prompt:=StrPtr(sPrompt), Caption:=StrPtr(sTitle), BUTTONS:=lButtons) Application.ScreenUpdating = bScreenUpdating End Function Function GetAccessToken() As String Static sAccess_Token As String, lExpirySeconds As Long, dtExpiry_Time As Date Const OAUTH_URI As String = "https://datamarket.accesscontrol.windows.net/v2/OAuth2-13" 'get Your Client ID and client secret from 'https://datamarket.azure.com/developer/applications Const CLIENT_ID As String = "Your Client ID" Const CLIENT_SECRET As String = "Your client secret" Dim sRequest As String, sResponse As String If Now() > dtExpiry_Time Then ' time for a new access token Dim webRequest As Object Set webRequest = CreateObject("MSXML2.XMLHTTP") 'Dim webRequest As MSXML2.XMLHTTP60 ' Add VBE reference to Microsoft XML, v6.0 'Set webRequest = new MSXML2.XMLHTTP60 sRequest = "grant_type=client_credentials" & _ "&client_id=" & CLIENT_ID & _ "&client_secret=" & URLEncodeUTF8(CLIENT_SECRET, False, False) & _ "&scope=http://api.microsofttranslator.com" '"GET" gets {"error":"invalid_request","error_description":"ACS90007: Request method not allowed. ... webRequest.Open "POST", OAUTH_URI, False webRequest.setRequestHeader "Content-Type", "application/x-www-form-urlencoded" webRequest.send (sRequest) ' brackets to coerce Variant type if using late binding sResponse = webRequest.responseText Set webRequest = Nothing If DEBUG_MODE Then Debug.Print sResponse '{"error":"invalid_client","error_description":"ACS50012: Authentication failed. \r\nTrace ID: 0a050673-ccfc-469a-9797-b27a49bfb4e6\r\nTimestamp: 2012-07-26 07:32:03Z"} If InStr(1, sResponse, """error:""", vbTextCompare) > 0 Then Err.Raise 9999, "GetAccessToken " & sResponse If DEBUG_MODE Then Stop ' to investigate End If ' Jan 2012 return order was access_token, token_type, July 2012 other way around '{"access_token":"http%3a%2f%2fschemas.xmlsoap.org%2fws%2f2005%2f05%2fidentity%2fclaims%2fnameidentifier=YourClientID... '"token_type":"http://schemas.xmlsoap.org/ws/2009/11/swt-token-profile-1.0" '"expires_in":"600" '"scope":"http://api.microsofttranslator.com"} sAccess_Token = NameValue("access_token", sResponse) If DEBUG_MODE Then Debug.Print URLDecode(sAccess_Token) lExpirySeconds = Val(NameValue("expires_in", sResponse)) ' expect 600 for 10 minutes expiry dtExpiry_Time = Now() + CDbl(lExpirySeconds - 10) / 60 / 60 / 24 ' 10 secs for safety margin If DEBUG_MODE Then Debug.Print lExpirySeconds; " secs, Token expires at "; Format$(dtExpiry_Time, "hh:mm:ss") End If GetAccessToken = sAccess_Token End Function 'returns what is inside pt Function StringFromXML(sText As String) As String Dim lPosGT As Long lPosGT = InStr(1, sText, ">") If lPosGT > 0 And lPosGT < Len(sText) Then StringFromXML = Mid$(sText, lPosGT + 1, InStr(lPosGT, sText, "<") - lPosGT - 1) End If End Function Function NameValue(ByVal sName As String, ByVal sResponse As String) As String ' return value part of "name":"value" without quotes from full response string Dim lPosStart As Long, lPosEnd As Long Const DQ = """" lPosStart = InStr(1, sResponse, DQ & sName & DQ & ":") ' "name": If lPosStart > 0 Then lPosStart = lPosStart + Len(sName) + 4 lPosEnd = InStr(lPosStart, sResponse, DQ) NameValue = Mid$(sResponse, lPosStart, lPosEnd - lPosStart) End If End Function ' Alternative methods of encoding 'http://stackoverflow.com/questions/218181/how-can-i-url-encode-a-string-in-excel-vba 'Excel 2013 'EncodedUrl = WorksheetFunction.EncodeUrl(InputString) Public Function URLEncodeUTF8( _ ByVal StringVal As String, _ Optional SpaceAsPlus As Boolean = False, _ Optional UTF8Encode As Boolean = True _ ) As String Dim StringValCopy As String StringValCopy = IIf(UTF8Encode, UTF16To8(StringVal), StringVal) Dim StringLen As Long StringLen = Len(StringValCopy) If StringLen > 0 Then ReDim Result(StringLen) As String Dim I As Long, CharCode As Integer Dim Char As String, Space As String If SpaceAsPlus Then Space = "+" Else Space = "%20" For I = 1 To StringLen Char = Mid$(StringValCopy, I, 1) CharCode = Asc(Char) ' AscW should not be needed here Select Case CharCode Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126 Result(I) = Char Case 32 Result(I) = Space Case 0 To 15 Result(I) = "%0" & Hex(CharCode) Case Else Result(I) = "%" & Hex(CharCode) End Select Next I URLEncodeUTF8 = Join(Result, "") End If End Function Public Function UTF16To8(ByVal UTF16 As String) As String Dim sBuffer As String Dim lLength As Long If UTF16 <> "" Then lLength = WideCharToMultiByte(CP_UTF8, 0, StrPtr(UTF16), -1, 0, 0, 0, 0) sBuffer = Space$(lLength) lLength = WideCharToMultiByte( _ CP_UTF8, 0, StrPtr(UTF16), -1, StrPtr(sBuffer), Len(sBuffer), 0, 0) sBuffer = StrConv(sBuffer, vbUnicode) UTF16To8 = Left$(sBuffer, lLength - 1) Else UTF16To8 = "" End If End Function 'adapted from http://www.freevbcode.com/ShowCode.asp?ID=1512 Public Function URLDecode(ByVal StringToDecode As String) As String Dim strTemp As String Dim lCurChar As Long lCurChar = 0 Do While lCurChar < Len(StringToDecode) lCurChar = lCurChar + 1 Select Case Mid(StringToDecode, lCurChar, 1) Case "+" strTemp = strTemp & " " Case "%" strTemp = strTemp & Chr(Val("&h" & _ Mid(StringToDecode, lCurChar + 1, 2))) lCurChar = lCurChar + 2 Case Else strTemp = strTemp & Mid(StringToDecode, lCurChar, 1) End Select Loop URLDecode = strTemp End Function