Option Explicit
Option Private Module
'---------------------------------------------------------------------------------------
' 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-2017 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
' : 19 Jan 2017 migrated to Azure portal because MS datamarket will be withdrawn April 20, 2017.
' Purpose : Functions to use Microsoft Text Translation service on Azure
' Usage note: sign up to Azure and get access key from MS
'---------------------------------------------------------------------------------------
'Sources of info for Microsoft Cognitive Services Azure Text Translation API
' Getting Started: http://docs.microsofttranslator.com/text-translate.html
' http://translatorbusiness.uservoice.com Microsoft Translator Hub Feedback and Support
' https://msdn.microsoft.com/en-us/library/ff512419.aspx HTTP interface
' https://msdn.microsoft.com/en-us/library/hh456380.aspx Translator Language Codes
' Not much yet on http://stackoverflow.com/questions/tagged/microsoft-cognitive
' Code samples: https://github.com/microsoftTranslator/
' https://www.microsoft.com/cognitive-services/en-us/pricing
' Translator Text API pricing tier has a plan limit of 2M characters per month: c.100K/day quota for a 20 day month.
'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
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
Private 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
Private Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
Private 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)
'https://translatorbusiness.uservoice.com/knowledgebase/articles/1082224-languages-detected-by-the-detect-method
'Note that Detect may detect languages that Microsoft Translator cannot translate.
If DEBUG_MODE Then Debug.Print "Language code: " & sLangID
'ShowMsgBox "Language: " & sLangID _
& vbLf & sText, vbInformation, "MicrosoftTranslatorDetect"
sTextTo = MicrosoftTranslate(sTextFrom, sLangID)
ShowMsgBox sTextFrom & vbLf & sLangID & "-->en" & vbLf & sTextTo, vbInformation, "MicrosoftTranslate"
End Sub
Function MicrosoftTranslate(ByVal sText As String, Optional ByVal sLanguageFrom As String = "", _
Optional ByVal sLanguageTo As String = "en") As String
' If empty 'From' language, the microsoft translator will detect it automatically
' In this function, omitting the Required 'to' language defaults to "en" = English.
Dim sRequest As String, sResponseText As String
sText = Trim$(sText)
If Len(sText) > 0 Then
If Len(sText) > 10000 Then
If ShowMsgBox("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
sRequest = "Translate?from=" & sLanguageFrom & "&to=" & sLanguageTo & "&text="
If DEBUG_MODE Then Debug.Print sText
sResponseText = MSHttpRequest(sRequest, sText)
'Clarity in the language
MicrosoftTranslate = StringFromXML(sResponseText)
If DEBUG_MODE Then Debug.Print MicrosoftTranslate
End If
End Function
'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. 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...)
Function MicrosoftTranslatorDetect(ByVal sText As String) As String
sText = Trim$(sText)
If Len(sText) > 0 Then
' returns lowercase two character code eg "fr"
MicrosoftTranslatorDetect = MSHttpRequest("Detect?text=", sText)
MicrosoftTranslatorDetect = StringFromXML(MicrosoftTranslatorDetect)
End If
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
'Sleep 1000 ' 1 sec pause if rate throttling needed.
' Also consider DoEvents in caller if many cells being translated in a loop
sToken = GetAccessToken()
Dim webRequest As Object ' late binding
Set webRequest = CreateObject("MSXML2.XMLHTTP")
'Dim webRequest As MSXML2.XMLHTTP60 ' early binding: Add reference in VBE to Microsoft XML, v6.0
'Set webRequest = new MSXML2.XMLHTTP60
webRequest.Open "GET", sURL, False
webRequest.setRequestHeader "Authorization", "Bearer " & sToken
webRequest.send
MSHttpRequest = webRequest.responseText
Set webRequest = Nothing
If StrComp(Left$(MSHttpRequest, 8), "
TranslateApiException
Method: Translate()
_
Message: Cannot find an active Azure Market Place Translator Subscription associated with the request credentials.