Code to call AWS Polly. If successful, returns a HTTP response object that contains the file.
Option Explicit
' Calls AWS Polly to prononuce sWord using sVoice and the AWS keys.
' Returns a MSXML2.ServerXMLHTTP response
Function CallPolly(sWord As String, sVoiceID As String, sOutputFormat As String, sAccessKey As String, _
sSecretKey As String, Optional sRegion As String = "eu-central-1") As Object
Set CallPolly = Nothing
Dim sHost, sEndpoint, sContentType, sRequestParameters, sAMZDate, sDateStamp, _
sStringtoSign, sCanonicalURI, sCanonicalQueryString, sCanonicalRequest, _
sPayloadhash, sCredentialScope, sSignature, sSignedHeaders, _
sCanonicalHeaders, sAuthorizationHeader As String
Dim dtDateTime As Date
Const sService As String = "polly"
Const sMethod As String = "POST"
Const sAPI As String = "/v1/speech"
Const sAlgorithm = "AWS4-HMAC-SHA256"
' Check access and secret keys
If ((sAccessKey = "") Or (sSecretKey = "")) Then
Debug.Print (vbLf & "No access key is available.")
Exit Function
End If
' Build host and endpoint from what we know
sHost = sService & "." & sRegion & ".amazonaws.com"
sEndpoint = "https://" & sHost & sAPI
' POST requests use a content type header. For Polly,
' the content is JSON.
sContentType = "application/x-amz-json-1.0"
' Request parameters for Polly, passed in a JSON block.
' Reference:
' https://docs.aws.amazon.com/polly/latest/dg/API_SynthesizeSpeech.html
sRequestParameters = "{""OutputFormat"": """ & sOutputFormat & """, "
sRequestParameters = sRequestParameters & """Text"": ""<speak>" & sWord & "</speak>"", "
sRequestParameters = sRequestParameters & """TextType"": ""ssml"", "
sRequestParameters = sRequestParameters & """VoiceId"": """ & sVoiceID & """}"
Debug.Print (vbLf & "RequestParameters:" & vbLf & sRequestParameters)
' Create a date for headers and the credential string
dtDateTime = getNowInUTC()
sAMZDate = Format(dtDateTime, "yyyymmdd\Thhnnss\Z")
sDateStamp = Format(dtDateTime, "yyyymmdd") ' Date w/o time, used in credential scope
' ************************************
' * TASK 1: CREATE A CANONICAL REQUEST
' ************************************
'
' Reference:
' http://docs.aws.amazon.com/general/latest/gr/sigv4-create-canonical-request.html
' Step 1: define the verb (GET, POST, etc.). Here: POST. Did that above by setting sMethod
' Step 2: Create canonical URI, i.e. the part of the URI from domain to query
' string.
sCanonicalURI = sAPI
' Step 3: Create the canonical query string. In this example, request
' parameters are passed in the body of the request and the query string
' is blank.
sCanonicalQueryString = ""
' Step 4: Create the canonical headers. Header names must be trimmed
' and lowercase, and sorted in code point order from low to high.
' Note that there is a trailing newline.
sCanonicalHeaders = "content-type:" & sContentType & vbLf & _
"host:" & sHost & vbLf & _
"x-amz-date:" & sAMZDate & vbLf
' Step 5: Create the list of signed headers. This lists the headers
' in the canonical headers list, delimited with ";" and in alphabetical
' order.
' Note: The request can include any headers; canonical headers and
' signed hearders include those that you want to be included in the
' hash of the request. "Host" and "x-amz-date" are always required.
' For Polly, content-type and x-amz-target are also required.
sSignedHeaders = "content-type;host;x-amz-date" ';x-amz-target"
' Step 6: Create payload hash. In this example, the payload (body of
' the request) contains the request parameters.
Dim bytRequestParameters() As Byte
bytRequestParameters = MyString2UTF8(sRequestParameters)
Dim bytPayloadHash() As Byte
bytPayloadHash = MySHA256(bytRequestParameters)
sPayloadhash = MyByteArrayToHex(bytPayloadHash)
' Step 7: Combine elements to create canonical request
sCanonicalRequest = sMethod & vbLf & _
sCanonicalURI & vbLf & _
sCanonicalQueryString & vbLf & _
sCanonicalHeaders & vbLf & _
sSignedHeaders & vbLf & _
sPayloadhash
Debug.Print (vbLf & "Canonical Request:" & vbLf & sCanonicalRequest)
' ***********************************
' * TASK 2: CREATE THE STRING TO SIGN
' ***********************************
' Match the algorithm to the hashing algorithm you use.
' We are using SHA-256 as recommended, Did that above
' by setting the sAlgorithm constant
Dim bytCanonicalRequest() As Byte
bytCanonicalRequest = MyString2UTF8(sCanonicalRequest)
sCredentialScope = sDateStamp & "/" & sRegion & "/" & sService & "/" & "aws4_request"
sStringtoSign = sAlgorithm & vbLf & _
sAMZDate & vbLf & _
sCredentialScope & vbLf & _
MyByteArrayToHex(MySHA256(bytCanonicalRequest))
Debug.Print (vbLf & "StringToSign:" & vbLf & sStringtoSign)
' *********************************
' * TASK 3: CALCULATE THE SIGNATURE
' *********************************
' Create the signing key
Dim bytSigningKey() As Byte
bytSigningKey = getSignatureKey(sSecretKey, sDateStamp, sRegion, sService)
' Sign sStringToSign using the signing key
Dim bytStringToSign() As Byte
bytStringToSign = MyString2UTF8(sStringtoSign)
Dim bytSignature() As Byte
bytSignature = MyHMACSHA256(bytStringToSign, bytSigningKey)
sSignature = MyByteArrayToHex(bytSignature)
' ************************************************
' * TASK 4: ADD SIGNING INFORMATION TO THE REQUEST
' ************************************************
' Put the signature information in a header named Authorization.
sAuthorizationHeader = sAlgorithm & " " & _
"Credential=" & sAccessKey & "/" & _
sCredentialScope & ", " & _
"SignedHeaders=" & sSignedHeaders & ", " & _
"Signature=" & sSignature
Debug.Print (vbLf & "AuthorizationHeader:" & vbLf & sAuthorizationHeader)
' ******************
' * SEND THE REQUEST
' ******************
Debug.Print (vbLf & "ATTENTION ALL UNITS!")
Debug.Print (vbLf & "BEGIN REQUEST!")
Debug.Print ("Request URL = " + sEndpoint)
Dim oHTTP As Object
Set oHTTP = CreateObject("MSXML2.ServerXMLHTTP")
oHTTP.Open "POST", sEndpoint, False
' For Polly, the request can include any headers, but MUST include "host", "content-type",
' "x-amz-date" and "authorization". Except for the authorization header,
' the headers must be included in the canonical headers and signed headers values, as
' noted earlier. Order here is not significant.
oHTTP.setrequestheader "content-type", sContentType
oHTTP.setrequestheader "host", sHost
oHTTP.setrequestheader "x-amz-date", sAMZDate
oHTTP.setrequestheader "authorization", sAuthorizationHeader
' Off you go, good luck
oHTTP.Send sRequestParameters
' Return the HTTP response back to the calling program.
Set CallPolly = oHTTP
End Function
' Key derivation function
Public Function getSignatureKey(ByVal sKey As String, ByVal sDateStamp As String, ByVal sRegionName As String, ByVal sServiceName As String) As Byte()
Dim bytSecretKey() As Byte
bytSecretKey = MyString2UTF8("AWS4" & sKey)
Dim bytDateKey() As Byte
bytDateKey = MyHMACSHA256(MyString2UTF8(sDateStamp), bytSecretKey)
Dim bytRegionKey() As Byte
bytRegionKey = MyHMACSHA256(MyString2UTF8(sRegionName), bytDateKey)
Dim bytServiceKey() As Byte
bytServiceKey = MyHMACSHA256(MyString2UTF8(sServiceName), bytRegionKey)
Dim bytSigningKey() As Byte
bytSigningKey = MyHMACSHA256(MyString2UTF8("aws4_request"), bytServiceKey)
getSignatureKey = bytSigningKey
End Function
' get UTC date & time
Private Function getNowInUTC() As Date
Dim dtUTCNow As Date
Dim oDateTime As Object
Set oDateTime = CreateObject("WbemScripting.SWbemDateTime")
oDateTime.SetVarDate Now
getNowInUTC = oDateTime.GetVarDate(False)
Set oDateTime = Nothing
End Function
Option Explicit
' WinApi function mapping UTF-16 (wide character) string to another format
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 cbMultiByte As Long, _
ByVal lpDefaultChar As Long, _
ByVal lpUsedDefaultChar As Long) As Long
' Maps a character string to a UTF-16 (wide character) string
Private Declare Function MultiByteToWideChar Lib "kernel32" ( _
ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpMultiByteStr As Long, _
ByVal cchMultiByte As Long, _
ByVal lpWideCharStr As Long, _
ByVal cchWideChar As Long _
) As Long
Private Declare Function CryptStringToBinary Lib "Crypt32" _
Alias "CryptStringToBinaryW" ( _
ByVal pszString As Long, _
ByVal cchString As Long, _
ByVal dwFlags As Long, _
ByVal pbBinary As Long, _
ByRef pcbBinary As Long, _
ByRef pdwSkip As Long, _
ByRef pdwFlags As Long) As Long
' CodePage constant for UTF-8
Private Const CP_UTF8 = 65001
' Return length of a byte array
Private Function BytesLength(bytBytes() As Byte) As Long
On Error Resume Next
BytesLength = UBound(bytBytes) - LBound(bytBytes) + 1
End Function
' Convert a String to an UTF-8-encoded array of bytes
Public Function MyString2UTF8(ByVal strInput) As Byte()
Dim lngBytes As Long
Dim bytBuffer() As Byte
If (strInput = "") Then Exit Function
' Get length of strInput in bytes including terminating null
lngBytes = WideCharToMultiByte(CP_UTF8, 0&, ByVal StrPtr(strInput), -1, 0&, 0&, 0&, 0&)
' Dim bytBuffer to disregard the terminating null
ReDim bytBuffer(lngBytes - 2)
lngBytes = WideCharToMultiByte(CP_UTF8, 0&, ByVal StrPtr(strInput), -1, ByVal VarPtr(bytBuffer(0)), lngBytes - 1, 0&, 0&)
MyString2UTF8 = bytBuffer
End Function
' Convert an array of bytes to a string containg the bytes' hex values
Function MyByteArrayToHex(ByRef bytBytes() As Byte) As String
Dim lngPosInString As Long, lngPosInBytes As Long
Dim sBuffer As String
MyByteArrayToHex = ""
If IsEmpty(bytBytes) Then Exit Function
sBuffer = Space$(2 * (UBound(bytBytes) - LBound(bytBytes)) + 2)
lngPosInString = 1
For lngPosInBytes = LBound(bytBytes) To UBound(bytBytes)
Mid$(sBuffer, lngPosInString, 2) = LCase(Right$("00" & Hex$(bytBytes(lngPosInBytes)), 2))
lngPosInString = lngPosInString + 2
Next
MyByteArrayToHex = sBuffer
End Function
' hash a message, provided as byte array, using SHA256
Public Function MySHA256(ByRef bytMessage() As Byte) As Byte()
Dim bytBuffer() As Byte
Dim oSHA256 As Object
Set oSHA256 = CreateObject("System.Security.Cryptography.SHA256Managed")
bytBuffer = oSHA256.ComputeHash_2(bytMessage)
MySHA256 = bytBuffer
Set oSHA256 = Nothing
End Function
' compute the HMAC of a message, provided as byte array, with a secret key using SHA256
Public Function MyHMACSHA256(ByRef bytMessage() As Byte, ByRef bytSecretKey() As Byte) As Byte()
Dim oEncoder As Object, oHMACSHA256 As Object
Set oEncoder = CreateObject("System.Text.UTF8Encoding")
Set oHMACSHA256 = CreateObject("System.Security.Cryptography.HMACSHA256")
oHMACSHA256.Key = bytSecretKey
Dim bytBuffer() As Byte
bytBuffer = oHMACSHA256.ComputeHash_2(bytMessage)
MyHMACSHA256 = bytBuffer
Set oEncoder = Nothing
Set oHMACSHA256 = Nothing
End Function
