HOWTO: EWS: Send UTF-16 request to Exchange Web Service from VBScript

I had explained earlier how you can consume Exchange Web Services like WebDAV from VBScript in the below sample

https://blogs.msdn.com/vikas/archive/2007/11/22/howto-ews-call-exchange-web-service-from-vbscript.aspx

Today I had a requirement to send Unicode request to the server but VBScript does not support Unicode. I workaround this situation, with the help of Notepad and VBScript.

In the notepad, write the XML that you need to pass on to the server. We will be using it as raw packet. We can use the following simplest FindItem call to list all the items from Inbox

 <?xml version="1.0" encoding="UTF-16"?>
<soap:Envelope xmlns:soap="https://schemas.xmlsoap.org/soap/envelope/" xmlns:t="https://schemas.microsoft.com/exchange/services/2006/types">
  <soap:Body>
    <FindItem xmlns="https://schemas.microsoft.com/exchange/services/2006/messages" Traversal="Shallow">
      <ItemShape>
        <t:BaseShape>Default</t:BaseShape>
      </ItemShape>
      <ParentFolderIds>
        <t:DistinguishedFolderId Id="inbox" />
      </ParentFolderIds>
    </FindItem>
  </soap:Body>
</soap:Envelope>

Copy paste the XML into the notepad and save it as UNICODE, make sure you select the UNICODE format while saving the notepad

Once done, now use the following script to send the packet to Exchange Web Service using MSXML’s ServerXMLHttp class.

 Const strCasServer = "CAS_SERVER_NAME"
Const strUsername = "USERNAME"
Const strPassword = "********"


Dim objXmlRequestor
Dim strBuffer
Dim strOutput

'Ignoring SSL Errors
Const SXH_OPTION_IGNORE_SERVER_SSL_CERT_ERROR_FLAGS = 2
Const SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS = 13056

Set objXmlRequestor = CreateObject("MSXML2.SERVERXMLHTTP")

'Reading the RAW UNICODE packet we just saved
strBuffer = ReadBinaryFile("packet.txt")

objXmlRequestor.setOption SXH_OPTION_IGNORE_SERVER_SSL_CERT_ERROR_FLAGS, SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS

'Sending the request to server
objXmlRequestor.open "POST", "https://" & strCasServer & "/ews/exchange.asmx",false
objXmlRequestor.setRequestHeader "Content-Type", "text/xml; charset=utf-16"

'Generating Base64 authorization string for BASIC authentication
objXmlRequestor.setRequestHeader "Authorization", "BASIC " & Base64Encode(strUsername & ":" & strPassword)

'Specify the User-Agent string
objXmlRequestor.setRequestHeader "User-Agent", "Visual Basic Scripting Client"
objXmlRequestor.setRequestHeader "Host", strCasServer

'Make sure you use LenB to get the corrent length from unicode string
objXmlRequestor.setRequestHeader "Content-Length", LenB(strBuffer)

objXmlRequestor.send strBuffer

strOutput = objXmlRequestor.getAllResponseHeaders & vbCrLf & objXmlRequestor.responseText

'Dump the response along with headers on to the screen
Wscript.echo strOutput


' Used for reading binary/unicode file
Function ReadBinaryFile(FileName)
  Const adTypeBinary = 1
  
  'Create Stream object
  Dim BinaryStream
  Set BinaryStream = CreateObject("ADODB.Stream")
  
  'Specify stream type - we want To get binary data.
  BinaryStream.Type = adTypeBinary
  
  'Open the stream
  BinaryStream.open
  
  'Load the file data from disk To stream object
  BinaryStream.LoadFromFile FileName
  
  'Open the stream And get binary data from the object
  ReadBinaryFile = BinaryStream.Read
End Function


Function Base64Encode(inputData)

  Const strBase64String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
  Dim cOut, sOut, I
  
  For I = 1 To Len(inputData) Step 3
    Dim nGroup, pOut, sGroup
    
    nGroup = &H10000 * Asc(Mid(inputData, I, 1)) + &H100 * RealASC(Mid(inputData, I + 1, 1)) + RealASC(Mid(inputData, I + 2, 1))
    
    nGroup = Oct(nGroup)
    
    nGroup = String(8 - Len(nGroup), "0") & nGroup
    
    'Convert To base64 string
    pOut = Mid(strBase64String , CLng("&o" & Mid(nGroup, 1, 2)) + 1, 1) + _
      Mid(strBase64String , CLng("&o" & Mid(nGroup, 3, 2)) + 1, 1) + _
      Mid(strBase64String , CLng("&o" & Mid(nGroup, 5, 2)) + 1, 1) + _
      Mid(strBase64String , CLng("&o" & Mid(nGroup, 7, 2)) + 1, 1)
    
    sOut = sOut + pOut
    
  Next
  Select Case Len(inputData) Mod 3
    Case 1: 
      sOut = Left(sOut, Len(sOut) - 2) + "=="
    Case 2: 
      sOut = Left(sOut, Len(sOut) - 1) + "="
  End Select
  Base64Encode = sOut
End Function

Function RealASC(SingleChar)
  If SingleChar = "" Then RealASC = 0 Else RealASCASC = Asc(SingleChar)
End Function