Attribute VB_Name = "MSTranslator"
Option Explicit
'---------------------------------------------------------------------------------------
' Module    : MSTranslator
' Author    : Patrick O'Beirne
'              Systems Modelling http://www.sysmod.com
'              http://ie.linkedin.com/in/patrickobeirne
' Date      : 10 Jan 2012
' Purpose   : Functions to use MicrosoftTranslator.com HTTP API
'---------------------------------------------------------------------------------------

'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

'VBE Tools > References :
'Microsoft XML, v6.0

Sub testMicrosoftTranslate()
'MsgBox MicrosoftTranslate("Ma déclaration d'impôts", "", "en") ' "My tax return"
MsgBox MicrosoftTranslate(ActiveCell), vbInformation, "Language: " & MicrosoftTranslatorDetect(ActiveCell)
End Sub

Function MicrosoftTranslate(sText As String, Optional sLanguageFrom As String = "", Optional sLanguageTo As String = "en") As String
Dim sRequest As String, sResponseText As String
   sRequest = "Translate?from=" & sLanguageFrom & "&to=" & sLanguageTo & "&text=" & sText
   sResponseText = MSHttpRequest(sRequest)
   'Debug.Print sResponseText
   MicrosoftTranslate = StringFromXML(sResponseText)
End Function

Function MicrosoftTranslatorDetect(sText As String) As String
 ' returns lowercase two character code eg "fr"
   MicrosoftTranslatorDetect = StringFromXML(MSHttpRequest("Detect?text=" & sText))
End Function

Function MSHttpRequest(sRequest As String) As String
Dim sURL As String, oH As MSXML2.XMLHTTP, sToken As String
   sURL = "http://api.microsofttranslator.com/V2/Http.svc/" & sRequest
   sToken = GetAccessToken()
   Set oH = CreateObject("MSXML2.XMLHTTP")
   oH.Open "GET", sURL, False
   oH.setRequestHeader "Authorization", "Bearer " & sToken
   oH.send
   MSHttpRequest = oH.responseText
   Set oH = Nothing
End Function

Function GetAccessToken() As String
Static sAccess_Token As String, dtExpiry_Time As Date
'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"
Const OAUTH_URI As String = "https://datamarket.accesscontrol.windows.net/v2/OAuth2-13"

Dim sRequest As String, arr As Variant
Dim webRequest As MSXML2.XMLHTTP
If Now() > dtExpiry_Time Then ' time for a new access token
   Set webRequest = CreateObject("MSXML2.XMLHTTP")
   
   sRequest = "grant_type=client_credentials" & _
         "&client_id=" & CLIENT_ID & _
         "&client_secret=" & URLEncode(CLIENT_SECRET) & _
         "&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
   arr = Split(webRequest.responseText, ",")
   If InStr(1, arr(0), "error") > 0 Then Err.Raise 9999, "GetAccessToken " & arr(0), arr(1)
   Set webRequest = Nothing
   
   'Debug.Print LBound(arr), UBound(arr), arr(0), arr(1), arr(2), arr(3)
   'arr(0)={"access_token":"http%3a%2f%2fschemas.xmlsoap.org%2fws%2f2005%2f05%2fidentity%2fclaims%2fnameidentifier=YourClientID...
   'arr(1)="token_type":"http://schemas.xmlsoap.org/ws/2009/11/swt-token-profile-1.0"
   'arr(2)="expires_in":"600"
   'arr(3)="scope":"http://api.microsofttranslator.com"}
   sAccess_Token = PairValue(arr(0))
   dtExpiry_Time = Now() + Val(PairValue(arr(2))) / 60 / 60 / 24 ' maybe *.95 for safety margin
   'Debug.Print "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(sText As String) As String
Dim lPosGT As Long
lPosGT = InStr(1, sText, ">")
StringFromXML = Mid$(sText, lPosGT + 1, InStr(lPosGT, sText, "<") - lPosGT - 1)
End Function


Function PairValue(ByVal sPair As String) As String ' return value part of "name":"value" without quotes
Dim lPosColon As Long
lPosColon = InStr(1, sPair, ":")
PairValue = Mid$(sPair, lPosColon + 2, Len(sPair) - lPosColon - 2)
End Function

Public Function URLEncode(StringVal As String, Optional SpaceAsPlus As Boolean = False) As String
Dim StringLen As Long
 StringLen = Len(StringVal)
 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$(StringVal, i, 1)
      CharCode = Asc(Char)
      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
   URLEncode = Join(result, "")
End If
End Function