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)
   '<string xmlns="http://schemas.microsoft.com/2003/10/Serialization/">Clarity in the language</string>
   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, "<string>", ",")
   GetLanguagesForTranslate = Replace(GetLanguagesForTranslate, "</string>", "")
   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), "<string ", vbTextCompare) = 0 Then
         ' it worked, a string was returned, use StringFromXML() to extract it
         bTrying = False
         ' return the XML
      Else
         ' it failed, html returned (probably)
         Select Case ShowMsgBox(sText & vbLf & Left$(HtmlToText(MSHttpRequest), 1024), _
               vbExclamation + vbRetryCancel, "Error")
         Case vbRetry
            ' keep trying
         Case vbCancel
            bTrying = False
            ' return the HTML.
         End Select
         If DEBUG_MODE Then Debug.Print MSHttpRequest: Stop ' to investigate and fix up
      End If
   Loop While bTrying
      '<html><body><h1>TranslateApiException</h1><p>Method: Translate()</p> _
         <p>Message: Cannot find an active Azure Market Place Translator Subscription associated with the request credentials.</p> _
         <code></code><p>message id=0824.V2_Rest.Translate.613D527C</p></body></html>
      ' Could be rate limited. Retry the request.
      
      '<html><body><h1>Argument Exception</h1><p>Method: Translate()</p><p>Parameter: </p> _
         <p>Message: No bearer information found in the token</p>
      'means you did not supply a valid Access Token
      
      '<html><body><h1>Argument Exception</h1><p>Method: Translate()</p> _
         <p>Parameter: from</p><p>Message: 'from' must be a valid language&#xD; _
         Parameter name: from</p><code></code><p>message id=0650.V2_Rest.Translate.502DC8C6</p></body></html>
   
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: <your account 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 <string xmlns="http://schemas.microsoft.com/2003/10/Serialization/">pt</string>
Function StringFromXML(ByVal sText As String) As String
Dim lPosGT As Long
If StrComp(Left$(sText, 8), "<string ", vbTextCompare) = 0 Then
   lPosGT = InStr(1, sText, ">")
   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 <string>"
End Function

Sub testHtmlToText()
Debug.Print HtmlToText("<html><body><h1>TranslateApiException</h1><p>Method: Translate()</p>" _
         & "<p>Message: Cannot find an active Azure Market Place Translator Subscription " _
         & "associated with the request credentials.</p>" _
         & "<code></code><p>message id=0824.V2_Rest.Translate.613D527C</p></body></html>")
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