SOAP - Using Excel as a Client

Back to SOAP

Step 1

Open up a new worksheet and select:

 Tools - Macro - Visual Basic Editor

Step 2

Select Tools - References and Tick Microsoft MSXML as shown below.

Step 3

Double Click on This Workbook and Cut and paste the following code into the VB Editor.

Private Function submitManifestForDespatch(URL As String, Username As String, Password As String, XML As String) As String
    Dim objXMLHTTP As New MSXML2.XMLHTTP
    Dim Request As String
   
    On Error GoTo ErrorHandler
   
    objXMLHTTP.Open "POST", URL, False
    objXMLHTTP.setRequestHeader "SOAPAction", "'http://tempuri.org/getXML"
    objXMLHTTP.setRequestHeader "Content-Type", "text/xml"
    objXMLHTTP.setRequestHeader "Authorization", "Basic " & Base64Encode(Username & ":" & Password)
    Request = Request & "<?xml version=""1.0"" encoding=""utf-8""?><soap:Envelope xmlns:soap=""http://schemas.xmlsoap.org/soap/envelope/"" "
    Request = Request & " xmlns:soapenc=""http://schemas.xmlsoap.org/soap/encoding/"" "
    Request = Request & " xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"" "
    Request = Request & " xmlns:xsd=""http://www.w3.org/2001/XMLSchema"">"
    Request = Request & "<soap:Body soap:encodingStyle=""http://schemas.xmlsoap.org/soap/encoding/"">"
    Request = Request & "<tns:submit>"
    Request = Request & "<string xsi:type=""xsd:string"">"
    Request = Request & XML
    Request = Request & "</string>"
    Request = Request & "</tns:submit></soap:Body></soap:Envelope>"
   
    objXMLHTTP.send Request
   
    submitManifestForDespatch = objXMLHTTP.responseText
   
    Exit Function
ErrorHandler:
    submitManifestForDespatch = Err.Description
End Function

Private Sub TestSOAPServer()
    Dim URL As String
    Dim Username As String
    Dim Password As String
    Dim XML As String
   
    URL = "https://test.performiq.com.au/submit?WSDL"
    Username = "soaptest"
    Password = "password"
    'Note That that all XML tags have been encoded\!\!\!\!
    XML = XML & "<..."
    XML = XML & "..."
    XML = XML & "..."

    Debug.Print submitManifestForDespatch(URL, Username, Password, XML)
   
End Sub

Private Sub Workbook_Open()
    On Error GoTo ErrorHandler
    Dim xmlResult
    Dim soapClient As New MSSOAPLib.soapClient
   
   
    TestSOAPServer
   
    Exit Sub
   
ErrorHandler:
    Debug.Print Err.Description
End Sub

Private Function Base64Encode(inData)
    'from: 'http://www.pstruh.cz/tips/detpg_Base64Encode.htm
    'rfc1521
    '2001 Antonin Foller, PSTRUH Software, [http://pstruh.cz]
    Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
    Dim sOut, I
 
    'For each group of 3 bytes
    For I = 1 To Len(inData) Step 3
        Dim nGroup, pOut
       
        'Create one long from this 3 bytes.
        nGroup = &H10000 * Asc(Mid(inData, I, 1)) + _
        &H100 * MyASC(Mid(inData, I + 1, 1)) + _
        MyASC(Mid(inData, I + 2, 1))
       
        'Oct splits the long To 8 groups with 3 bits
        nGroup = Oct(nGroup)
       
        'Add leading zeros
        nGroup = String(8 - Len(nGroup), "0") & nGroup
       
        'Convert To base64
        pOut = Mid(Base64, CLng("&o" & Mid(nGroup, 1, 2)) + 1, 1) + _
        Mid(Base64, CLng("&o" & Mid(nGroup, 3, 2)) + 1, 1) + _
        Mid(Base64, CLng("&o" & Mid(nGroup, 5, 2)) + 1, 1) + _
        Mid(Base64, CLng("&o" & Mid(nGroup, 7, 2)) + 1, 1)
       
        'Add the part To OutPut string
        sOut = sOut + pOut
    Next
   
    Select Case Len(inData) Mod 3
    Case 1: '8 bit final
        sOut = Left(sOut, Len(sOut) - 2) + "=="
    Case 2: '16 bit final
        sOut = Left(sOut, Len(sOut) - 1) + "="
    End Select
   
    Base64Encode = sOut
End Function

Private Function MyASC(OneChar)
    If OneChar = "" Then MyASC = 0 Else MyASC = Asc(OneChar)
End Function