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.

_

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

End Function ' Ensure messagebox appears and disappears properly Function ShowMsgBox(ByVal sPrompt As String, ByVal lButtons As VbMsgBoxStyle, ByVal 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, sStatusCode As String Dim sRequest As String, sResponse As String If Now() > dtExpiry_Time Then ' time for a new access token ' Jan-2017: Azure portal Const AUTH_URI As String = "https://api.cognitive.microsoft.com/sts/v1.0/issueToken" Const ACCOUNT_KEY As String = "Your Account Key" ' see Getting Started guide for how to sign up for this '"GET" gets {"error":"invalid_request","error_description":"ACS90007: Request method not allowed. ... Dim webRequest As Object ' late binding Set webRequest = CreateObject("MSXML2.XMLHTTP") 'Dim webRequest As MSXML2.XMLHTTP60 ' eary binding: add reference in VBE to Microsoft XML, v6.0 'Set webRequest = new MSXML2.XMLHTTP60 webRequest.Open "POST", AUTH_URI, False webRequest.setRequestHeader "Content-Type", "application/json" webRequest.setRequestHeader "Accept", "application/jwt" 'application/jwt is JSON Web Token: three Base64 strings separated by dots : header.payload.signature 'curl -X POST --header 'Content-Type: application/json' --header 'Accept: application/jwt' _ --header 'Ocp-Apim-Subscription-Key: ' _ 'https://api.cognitive.microsoft.com/sts/v1.0/issueToken' webRequest.setRequestHeader "Ocp-Apim-Subscription-Key", ACCOUNT_KEY ' Azure sRequest = "" 'query method does not work: 'sRequest = "?Subscription-Key=" & ACCOUNT_KEY '{ "statusCode": 401, "message": "Access denied due to missing subscription key. _ Make sure to include subscription key when making requests to an API." } 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 sStatusCode = NameValue("statusCode", sResponse) If Not sStatusCode = "" Then ShowMsgBox sResponse, vbExclamation, "GetAccessToken error" If DEBUG_MODE Then Stop ' to investigate End If sAccess_Token = sResponse ' JSON Web Token lExpirySeconds = 600 ' Azure fixed at 10 minutes. dtExpiry_Time = Now() + CDbl(lExpirySeconds - 10) / 60# / 60# / 24# ' less 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(ByVal sText As String) As String Dim lPosGT As Long If StrComp(Left$(sText, 8), "") If lPosGT > 0 And lPosGT < Len(sText) Then StringFromXML = Mid$(sText, lPosGT + 1, InStr(lPosGT, sText, "<") - lPosGT - 1) Exit Function End If End If ShowMsgBox Left$(sText, 1024), vbExclamation, "Not an XML " End Function Sub testHtmlToText() Debug.Print HtmlToText("

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

") End Sub 'https://www.experts-exchange.com/questions/27740991/Stripping-HTML-from-an-Excel-column-and-replacing-it-with-plain-text.html Function HtmlToText(ByVal sHTML) As String Dim oDoc As Object ' HTMLDocument Set oDoc = CreateObject("HTMLfile") 'New HTMLDocument oDoc.body.innerHTML = sHTML HtmlToText = oDoc.body.innerText Set oDoc = Nothing End Function ' return value part of "name":"value" without quotes from full response string Function NameValue(ByVal sName As String, ByVal sResponse As String) As 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) Private 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 Private Function UTF16To8(ByVal UTF16 As String) As String Dim sBuffer As String Dim lLength As Long If UTF16 <> "" Then 'eg Japanese two symbols for Tokyo 'What the browser sends is 2x3 hex chars: %E6%9D%B1%E4%BA%AC 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 Private 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