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, "
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. 'Method: Translate()
Parameter:
_Message: No bearer information found in the token
'means you did not supply a valid Access Token '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