access vba bombs when defining html results page as variable to extract content from php page - vba

My client is trying to use an access VBA script to send a string to a php page i created, then bring the data that is returned on the page back into his db
i use a mac and cannot run any of the VB code, but here is what i was able to find (two versions), but both bomb in the first dim statement
Private Sub Command1_Click()
Dim iHTML As HTMLDocument
Dim objHttp As MSXML2.ServerXMLHTTP
set objHttp = CreateObject("Msxml2.ServerXMLHTTP")
objHttp.open "GET", "http://www.bestenergyctri.com/zipcode.php?isValidate=adb&address1=352%20w%2046&address2=&city=new%20york&state=ny&zip5=
", False
objHttp.send
Set iHTML = objHttp.ResponseText
straddress1 = iHTML.getElementsByClassName("detect").Item(x - 1).getElementsByClassName("thedata").Item(0).getElementsByClassName("address1").Item(1).innerText
straddress2 = iHTML.getElementsByClassName("detect").Item(x - 1).getElementsByClassName("thedata").Item(0).getElementsByClassName("address2").Item(1).innerText
strcity = iHTML.getElementsByClassName("detect").Item(x - 1).getElementsByClassName("thedata").Item(0).getElementsByClassName("City").Item(1).innerText
strstate = iHTML.getElementsByClassName("detect").Item(x - 1).getElementsByClassName("thedata").Item(0).getElementsByClassName("State").Item(1).innerText
strzip5 = iHTML.getElementsByClassName("detect").Item(x - 1).getElementsByClassName("thedata").Item(0).getElementsByClassName("Zip5").Item(1).innerText
strzip4 = iHTML.getElementsByClassName("detect").Item(x - 1).getElementsByClassName("thedata").Item(0).getElementsByClassName("Zip4").Item(1).innerText
SaveWebInfo straddress1, straddress2, strcity, strstate, strzip5, strzip4
Set iHTML = Nothing
Set objHttp = Nothing
End Sub
or
Private Sub Command1_Click()
Dim iHTML As HTMLDocument
Dim objHttp As MSXML2.ServerXMLHTTP
set objHttp = New MSXML2.ServerXMLHTTP
objHttp.open "GET", "http://www.bestenergyctri.com/zipcode.php?isValidate=adb&address1=352%20w%2046&address2=&city=new%20york&state=ny&zip5=
", False
objHttp.send
Set iHTML = objHttp.ResponseText
straddress1 = iHTML.getElementsByClassName("detect").Item(x - 1).getElementsByClassName("thedata").Item(0).getElementsByClassName("address1").Item(1).innerText
straddress2 = iHTML.getElementsByClassName("detect").Item(x - 1).getElementsByClassName("thedata").Item(0).getElementsByClassName("address2").Item(1).innerText
strcity = iHTML.getElementsByClassName("detect").Item(x - 1).getElementsByClassName("thedata").Item(0).getElementsByClassName("City").Item(1).innerText
strstate = iHTML.getElementsByClassName("detect").Item(x - 1).getElementsByClassName("thedata").Item(0).getElementsByClassName("State").Item(1).innerText
strzip5 = iHTML.getElementsByClassName("detect").Item(x - 1).getElementsByClassName("thedata").Item(0).getElementsByClassName("Zip5").Item(1).innerText
strzip4 = iHTML.getElementsByClassName("detect").Item(x - 1).getElementsByClassName("thedata").Item(0).getElementsByClassName("Zip4").Item(1).innerText
SaveWebInfo straddress1, straddress2, strcity, strstate, strzip5, strzip4
Set iHTML = Nothing
Set objHttp = Nothing
End Sub
does anyone have any suggestions on how we can get the page properly read into a variable so that it can be parsed
thanks

Here is a simpler example using CSS querySelector and avoiding using Hungarian notation
Code:
Option Explicit
Sub test()
Dim iHTML As New HTMLDocument, objHttp As MSXML2.ServerXMLHTTP60 '<== Note this is version specific syntax. 60 is for Excel 2016
Set objHttp = New MSXML2.ServerXMLHTTP60
objHttp.Open "GET", "http://www.bestenergyctri.com/zipcode.php?isValidate=adb&address1=352%20w%2046&address2=&city=new%20york&state=ny&zip5=", False
objHttp.send
Dim address1 As String, address2 As String, city As String, state As String, zip5 As String, zip4 As String
With iHTML
.body.innerHTML = objHttp.ResponseText
address1 = .querySelector(".address1").innerText
address2 = .querySelector(".address2").innerText
city = .querySelector(".City").innerText
state = .querySelector(".State").innerText
zip5 = .querySelector(".Zip5").innerText
zip4 = .querySelector(".Zip4").innerText
End With
Debug.Print "Address 1: " & address1
Debug.Print "Address 2: " & address2
Debug.Print "City: " & city
Debug.Print "State: " & state
Debug.Print "Zip5: " & zip5
Debug.Print "Zip4: " & zip4
End Sub
Output:
References added to VBA > Tools > References:
*Last two references are the important ones.

Related

MSXML2.XMLHTTP method data extraction issue

I am using MSXML2.XMLHTTP method for data extraction but unable to extract data from specific page
Currently using following code for data extraction from different pages.This code is working fine with other pages but not working proper for specific page.
I want to extract following values for sample page.Price,Seller name etc
Dim http As Object, html As New MSHTML.HTMLDocument, topics As Object, titleElem As Object, detailsElem As Object, topic As HTMLHtmlElement
Dim j As Long
Dim RowCount As String
Dim maxid As Long
Dim productdesc1 As String
Dim features As String
Dim news As String
Dim comb As String
t122 = Now
Rin = DMin("[id]", "url", "[Flag] = False")
If Not IsNull(Rin) Then
Set http = CreateObject("MSXML2.XMLHTTP")
'http = http.SetOption(2, 13056)
'; //ignore all SSL Cert issues
RowCount = DMin("[id]", "url", "[Flag] = False")
maxid = DMax("[id]", "url", "[Flag] = False")
'MsgBox (RowCount)
Do While RowCount <> ""
'RowCount = DMin("[id]", "url", "[Flag] = False")
url = DLookup("[url]", "url", "ID = " & ([RowCount]))
url = Trim(url)
t31 = ""
t31 = (DateDiff("n", t122, Now))
On Error Resume Next
http.Open "GET", url, False
http.Send
html.body.innerHTML = http.ResponseText
brand = html.body.innerText
Set my_data1 = html.getElementsByClassName("a-row a-spacing-mini olpOffer")
i = 1
For Each Item In my_data1
pr1 = Item.getElementsByClassName("a-size-large a-color-price olpOfferPrice a-text-bold")
pr2 = pr1.innerText
dlmsg = Item.innerHTML
If dlmsg Like "*olpShippingPrice*" Then
dpr = Item.getElementsByClassName("olpShippingPrice")
dpr2 = dpr.innerText
End If
Data should be visible from following webpage using above code.https://www.amazon.co.uk/gp/offer-listing/B00551P0Q8
The following will print out all. You can sort where to write the values to
Option Explicit
Public Sub Test()
Dim prices As Object, sellers As Object, html As HTMLDocument, i As Long
Set html = New HTMLDocument
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://www.amazon.co.uk/gp/offer-listing/B01GK4YHMQ", False
.Send
html.body.innerHTML = .ResponseText
End With
Set prices = html.querySelectorAll(".olpOfferPrice")
Set sellers = html.querySelectorAll(".olpSellerName a")
For i = 0 To prices.Length - 1
Debug.Print Trim$(prices.Item(i).innerText)
Debug.Print Trim$(sellers.Item(i).innerText)
Next
End Sub

How to connect MS Word to microsoft's QnA Maker (VBA)

I am trying to connect MS Word to Microsoft's QnAMaker using VBA to help answer a wide variety of similar questions I receive.
My idea is select the question and then have vba query the answer and copy it to the clipboard (templates for replies are different, this way I can select where to output the answer).
Any help is appreciated. Thank you.
(I am using this JSON library: https://github.com/VBA-tools/VBA-JSON)
I have already applied the suggested solutions described in the issue section below: https://github.com/VBA-tools/VBA-JSON/issues/68
Sub copyAnswer()
'User Settings
Dim questionWorksheetName As String, questionsColumn As String,
firstQuestionRow As String, kbHost As String, kbId As String, endpointKey
As String
Dim str As String
str = Selection.Text
kbHost = "https://rfp1.azurewebsites.net/********"
kbId = "********-********-*********"
endpointKey = "********-********-********"
'Loop through all non-blank cells
Dim answer, score As String
Dim myArray() As String
Dim obj As New DataObject
answer = GetAnswer(str, kbHost, kbId, endpointKey)
Call ClipBoard_SetData(answer)
End Sub
Function GetAnswer(question, kbHost, kbId, endpointKey) As String
'HTTP Request Settings
Dim qnaUrl As String
qnaUrl = kbHost & "/knowledgebases/" & kbId & "/generateAnswer"
Dim contentType As String
contentType = "application/json"
Dim data As String
data = "{""question"":""" & question & """}"
'Send Request
Dim xmlhttp As New MSXML2.XMLHTTP60
xmlhttp.Open "POST", qnaUrl, False
xmlhttp.setRequestHeader "Content-Type", contentType
xmlhttp.setRequestHeader "Authorization", "EndpointKey " & endpointKey
**xmlhttp.send data**
'Convert response to JSON
Dim json As Scripting.Dictionary
Set json = JsonConverter.ParseJson(xmlhttp.responseText)
Dim answer As Scripting.Dictionary
For Each answer In json("answers")
'Return response
GetAnswer = answer("answer")
Next
End Function
Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As Scripting.Dictionary
Dim json_Key As String
Dim json_NextChar As String
Set json_ParseObject = New Scripting.Dictionary
json_SkipSpaces json_String, json_Index
...
I am encountering the following error which I am uncertain how to resolve: "This method cannot be called after the send method has been called".
The error occurs on the line: xmlhttp.send data
The GitHub issue you linked kind of had the answer, but it's not complete. Here's what you do (from the VBA Dev Console in Word):
In Modules > JsonConverter
Go to Private Function json_ParseObject
Add Scripting. to Dictionary in two places:
from:
Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As Dictionary
to:
Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As Scripting.Dictionary
and from:
Set json_ParseObject = New Dictionary
to:
Set json_ParseObject = New Scripting.Dictionary
In GetAnswer():
Also change from:
Dim json As Dictionary
to:
Dim json As Scripting.Dictionary
and from:
Dim answer As Dictionary
to:
Dim answer As Scripting.Dictionary
Here's my full working code:
In ThisDocument:
Sub copyAnswer()
'User Settings
Dim kbHost As String, kbId As String, endpointKey As String
Dim str As String
str = "test"
kbHost = "https:/*********.azurewebsites.net/qnamaker"
kbId = "***************************"
endpointKey = "*************************"
'Loop through all non-blank cells
Dim answer, score As String
Dim myArray() As String
answer = GetAnswer(str, kbHost, kbId, endpointKey)
End Sub
Function GetAnswer(question, kbHost, kbId, endpointKey) As String
'HTTP Request Settings
Dim qnaUrl As String
qnaUrl = kbHost & "/knowledgebases/" & kbId & "/generateAnswer"
Dim contentType As String
contentType = "application/json"
Dim data As String
data = "{""question"":""" & question & """}"
'Send Request
Dim xmlhttp As New MSXML2.XMLHTTP60
xmlhttp.Open "POST", qnaUrl, False
xmlhttp.setRequestHeader "Content-Type", contentType
xmlhttp.setRequestHeader "Authorization", "EndpointKey " & endpointKey
xmlhttp.send data
'Convert response to JSON
Dim json As Scripting.Dictionary
Set json = JsonConverter.ParseJson(xmlhttp.responseText)
Dim answer As Scripting.Dictionary
For Each answer In json("answers")
'Return response
GetAnswer = answer("answer")
Next
End Function
In Modules > JsonConverter
Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As Scripting.Dictionary
Dim json_Key As String
Dim json_NextChar As String
Set json_ParseObject = New Scripting.Dictionary
json_SkipSpaces json_String, json_Index
If VBA.Mid$(json_String, json_Index, 1) <> "{" Then
Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '{'")
Else
json_Index = json_Index + 1
Do
json_SkipSpaces json_String, json_Index
If VBA.Mid$(json_String, json_Index, 1) = "}" Then
json_Index = json_Index + 1
Exit Function
ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then
json_Index = json_Index + 1
json_SkipSpaces json_String, json_Index
End If
json_Key = json_ParseKey(json_String, json_Index)
json_NextChar = json_Peek(json_String, json_Index)
If json_NextChar = "[" Or json_NextChar = "{" Then
Set json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index)
Else
json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index)
End If
Loop
End If
End Function

Can't parse phone number from a page hindered by <br> tag

Tried to get the contact details from a page but when i run my script it only grabs the first portion of each category and ignores the rest because of some br tag, as in from contact details category it only grabs the name not the phone number or fax. Hope somebody will give me any idea how i could get that? Here is what I tried with:
Sub RestData()
Dim http As New MSXML2.XMLHTTP60
Dim html As New HTMLDocument
Dim ele As Object, post As Object
With CreateObject("MSXML2.serverXMLHTTP")
.Open "GET", "http://www.austrade.gov.au/SupplierDetails.aspx?ORGID=ORG0120000508&folderid=1736", False
.send
html.body.innerHTML = .responseText
End With
Set ele = html.getElementsByClassName("contact-details block dark")(0).getElementsByTagName("p")
For Each post In ele
x = x + 1
Cells(x, 1) = post.innerText
Next post
Set html = Nothing: Set ele = Nothing: Set docs = Nothing
End Sub
Html element for that:
<p>Company Name: Vaucraft Braford Stud<br>Phone: +61 7 4942 4859<br>Fax: +61 7 4942 0618<br>Email: florfamily1#bigpond.com<br>Web: <a target="_blank" href="http://www.vaucraftbrafords.com.au">http://www.vaucraftbrafords.com.au</a></p>
You may try something like this...
Sub RestData()
Dim http As New MSXML2.XMLHTTP60
Dim html As New HTMLDocument
Dim ele As Object, post As Object
Dim TypeDetails() As String
Dim TypeDetail() As String
Dim i As Long, r As Long
With CreateObject("MSXML2.serverXMLHTTP")
.Open "GET", "http://www.austrade.gov.au/SupplierDetails.aspx?ORGID=ORG0120000508&folderid=1736", False
.send
html.body.innerHTML = .responseText
End With
Set ele = html.getElementsByClassName("contact-details block dark")(0).getElementsByTagName("p")(2)
r = 2
TypeDetails() = Split(ele.innerText, Chr(10))
For i = 0 To UBound(TypeDetails)
TypeDetail() = Split(TypeDetails(i), ":")
Cells(r, 1) = VBA.Trim(TypeDetail(0))
Cells(r, 2) = VBA.Trim(TypeDetail(1))
r = r + 1
Next i
Set html = Nothing: Set ele = Nothing: Set docs = Nothing
End Sub

Parsing xml string in VBA

I am trying to parse xml document that i am getting from a website.
from some reason i cant figure out i cant parse the value inside the 'RATE' node.
the xml string seems O.K.
but in the end of the code (commented) i get Object variable or With block variable not set error.
i will be grateful for any help.
XML STRING:
<?xml version="1.0" encoding="utf-8" standalone="yes"?>
<CURRENCIES>
<LAST_UPDATE>2016-01-25</LAST_UPDATE>
<CURRENCY>
<NAME>Dollar</NAME>
<UNIT>1</UNIT>
<CURRENCYCODE>USD</CURRENCYCODE>
<COUNTRY>USA</COUNTRY>
<RATE>3.982</RATE>
<CHANGE>0.277</CHANGE>
</CURRENCY>
</CURRENCIES>
VBA CODE:
Private Sub loadXMLString(xmlString)
Dim strXML As String
Dim xNode As IXMLDOMNode
Dim XDoc As MSXML2.DOMDocument
strXML = xmlString
Set XDoc = New MSXML2.DOMDocument
If Not XDoc.LoadXML(strXML) Then 'strXML is the string with XML'
Err.Raise XDoc.parseError.ErrorCode, , XDoc.parseError.reason
End If
Set xNode = XDoc.FirstChild
Debug.Print xNode.SelectSingleNode("RATE").Text ' here i get the Object variable or With block variable not set error
Debug.Print xNode.ChildNodes(2).SelectSingleNode("RATE").Text ' also with that try i get the Object variable or With block variable not set error
End Sub
UPDATE:
i found the problem (as i wrote down in the comments to #Nathan).
the problem is the <?xml version="1.0" encoding="utf-8" standalone="yes"?> node
Tested it an this code is working:
so how can i do that with out to remove this node as a substring, there must be a way i guess, but i dont have a lot of experience working with XML
Private Sub loadXMLString(xmlString)
Dim strXML As String
Dim xNode As IXMLDOMNode
Dim XDoc As MSXML2.DOMDocument
strXML = "<CURRENCIES>" & _
"<LAST_UPDATE>2016-01-25</LAST_UPDATE>" & _
"<CURRENCY>" & _
"<NAME>Dollar</NAME>" & _
"<UNIT>1</UNIT>" & _
"<CURRENCYCODE>USD</CURRENCYCODE>" & _
"<COUNTRY>USA</COUNTRY>" & _
"<RATE>3.982</RATE>" & _
"<CHANGE>0.277</CHANGE>" & _
"</CURRENCY>" & _
"</CURRENCIES>"
Set XDoc = New MSXML2.DOMDocument
If Not XDoc.LoadXML(strXML) Then 'strXML is the string with XML'
Err.Raise XDoc.parseError.ErrorCode, , XDoc.parseError.reason
End If
Set xNode = XDoc.FirstChild
Debug.Print strXML
Debug.Print xNode.ChildNodes(1).SelectSingleNode("RATE").Text ' also with that try i get the Object variable or With block variable not set error
End Sub
SelectSingleNode() expects an XPath expression. Try this one:
xNode.SelectSingleNode("//RATE").Text
But in general it's not very smart to access properties of an object reference that could be Nothing – like it is in the above case, if SelectSingleNode does not find any matching node, this line will trigger a run-time error ("Object variable or With block variable not set", which effectively is a null pointer exception.)
Always guard your property accesses by validating your object reference:
Set rate = xNode.SelectSingleNode("//RATE")
If rate Is Nothing Then
Debug.Print "Error: no RATE found in document"
Else
Debug.Print rate.Text
End If
FWIW, here is a complete version of the code I would use, featuring a few nice details like a custom type for currency information and the use the Sleep() function to wait for the server to return the XML document:
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Type CurrencyInfo
Success As Boolean
LastUpdate As Date
Name As String
Unit As Double
CurrencyCode As String
Country As String
Rate As Double
Change As Double
End Type
Private Function GetXmlDoc(url As String) As MSXML2.DOMDocument60
With New MSXML2.XMLHTTP60
.Open "GET", url, False
.send
While .readyState <> 4: Sleep 50: Wend
If .Status = 200 Then
If .responseXML.parseError.ErrorCode = 0 Then
Set GetXmlDoc = .responseXML
Else
Err.Raise vbObjectError + 1, "GetXmlDoc", "XML parser error: " & .responseXML.parseError.reason
End If
Else
Err.Raise vbObjectError + 2, "GetXmlDoc", "Server responded with status code " & .Status
End If
End With
End Function
Public Function GetCurrencyInfo(currencyName As String) As CurrencyInfo
Dim curr As MSXML2.DOMDocument60
Set curr = GetXmlDoc("http://the/url/you/use?currency=" + currencyName)
GetCurrencyInfo.Success = True
GetCurrencyInfo.LastUpdate = CDate(GetText(curr, "//LAST_UPDATE"))
GetCurrencyInfo.Name = GetText(curr, "//NAME")
GetCurrencyInfo.Unit = Val(GetText(curr, "//UNIT"))
GetCurrencyInfo.CurrencyCode = GetText(curr, "//CURRENCYCODE")
GetCurrencyInfo.Country = GetText(curr, "//COUNTRY")
GetCurrencyInfo.Rate = Val(GetText(curr, "//RATE"))
GetCurrencyInfo.Change = Val(GetText(curr, "//CHANGE"))
End Function
Private Function GetText(context As IXMLDOMNode, path As String) As String
Dim result As IXMLDOMNode
If Not context Is Nothing Then
Set result = context.SelectSingleNode(path)
If Not result Is Nothing Then GetText = result.Text
End If
End Function
Usage is as follows:
Sub Test()
Dim USD As CurrencyInfo
USD = GetCurrencyInfo("USD")
Debug.Print "LastUpdate: " & USD.LastUpdate
Debug.Print "Name: " & USD.Name
Debug.Print "Unit: " & USD.Unit
Debug.Print "CurrencyCode: " & USD.CurrencyCode
Debug.Print "Country: " & USD.Country
Debug.Print "Rate: " & USD.Rate
Debug.Print "Change: " & USD.Change
End Sub
Tried this, and got somwhere.
Dim strXML As String
Dim xNode As IXMLDOMNode
Dim XDoc As MSXML2.DOMDocument
Dim xParent As IXMLDOMNode
Dim xChild As MSXML2.IXMLDOMNode
strXML = xmlString
Set XDoc = New MSXML2.DOMDocument
If Not XDoc.Load(strXML) Then 'strXML is the string with XML'
Err.Raise XDoc.parseError.ErrorCode, , XDoc.parseError.reason
End If
Set xNode = XDoc.DocumentElement
Set xParent = xNode.FirstChild
For Each xParent In xNode.ChildNodes
For Each xChild In xParent.ChildNodes
Debug.Print xChild.Text
Next xChild
Next xParent

Excel vba and XMLHTTP with ADFS - not returning xml

I have an Excel macro that has been in use for years which posts to a database using an XMLHttp call. The code is digitally signed.
Recently the site which is being posted to has enabled ADFS. Now instead of getting xml back I get the contents of the ADFS authentication form. There is no prompt for credentials in it since authentication already occurred. It I open the url from a web browser it goes through as expected with existing credentials used and the page loaded.
I tried setting the trusted setting for the url and allowed external content but that didn't matter.
Have I missed something?
The html I get back looks like...
<html><head><title>Working...</title></head><body><form method="POST" name="hiddenform" action="https://isvcci.jttest.com:444/"><input type="hidden" name="wa" value="wsignin1.0" />
...
<noscript><p>Script is disabled. Click Submit to continue.</p><input type="submit" value="Submit" /></noscript></form><script language="javascript">window.setTimeout('document.forms[0].submit()', 0);</script></body></html>
This is the vba:
Sub PostXml(strType As String, strAddress As String, objXml As MSXML2.DOMDocument60)
Dim objHttp As MSXML2.XMLHTTP60, objXmlResponse As MSXML2.DOMDocument60, objNode As MSXML2.IXMLDOMNode
Dim strText As String
Set objHttp = New MSXML2.XMLHTTP60
objHttp.Open "POST", strAddress, False
objHttp.setRequestHeader "Content-Type", "text/xml; charset=utf-8"
objHttp.send objXml
Set objXmlResponse = objHttp.responseXML
rem responseXML is always empty but responseText has the adfs page <------
Set objNode = objXmlResponse.SelectSingleNode("root/errorMessage")
If objNode Is Nothing Then
MsgBox "Error: Unable to retrieve expected response from the server." + vbCrLf + "The opportunity may not have been updated."
Else
... code for success goes here
End If
End Sub
Thanks for any assistance!
XMLHttp wouldn't work over adfs so I used an InternetExplorer control instead. It's a hassle to get the resulting xml back though using a page which sets a form value would probably be simpler. The resulting xml gets returned formatted like what you see in a web browser. I use a simple regex to remove dashes outside of tags.
I'm not that experienced with vba and excel so there might be better ways to code this but it works.
Sub PostXml(strType As String, strAddress As String, objXml As MSXML2.DOMDocument60)
Dim objHttp As MSXML2.XMLHTTP60, objXmlResponse As MSXML2.DOMDocument60, objNode As MSXML2.IXMLDOMNode
Dim objDoc As MSHTML.HTMLDocument
Dim strText As String, strHeaders As String, strPostData As String
Dim MyBrowser As InternetExplorer
Dim PostData() As Byte
Dim expr As VBScript_RegExp_55.RegExp
Dim colMatch As VBScript_RegExp_55.MatchCollection
Dim vbsMatch As VBScript_RegExp_55.Match
Dim sMatchString As String
' XMLHttp doesn't work with ADFS so browser was used
Set MyBrowser = New InternetExplorer
strHeaders = "Content-Type: text/xml; charset=utf-8" & vbCrLf
PostData = StrConv(objXml.XML, vbFromUnicode)
MyBrowser.Visible = False
MyBrowser.navigate strAddress, 0, "", PostData, strHeaders
Do While MyBrowser.Busy Or MyBrowser.readyState <> 4
Loop
Set objDoc = MyBrowser.Document
strText = objDoc.body.innerText
Set expr = New VBScript_RegExp_55.RegExp
expr.Pattern = "(?:\s| |^)(-)(?=\s|\r|\n|$)"
expr.IgnoreCase = True
expr.MultiLine = True
expr.Global = True
strText = expr.Replace(strText, "")
Set objXmlResponse = New MSXML2.DOMDocument60
Set objNode = Nothing
If objXmlResponse.LoadXML(strText) Then
Set objNode = objXmlResponse.SelectSingleNode("root/errorMessage")
'Else
'MsgBox "Invalid XML " & objXmlResponse.parseError.ErrorCode & "," & objXmlResponse.parseError.reason
End If
MyBrowser.Quit
Set MyBrowser = Nothing
Rem MsgBox "response =" & vbCrLf & objXmlResponse.XML
If objNode Is Nothing Then
MsgBox "Error: Unable to retrieve expected response from the server."
Else
strText = objNode.Text
If strText > "" Then
MsgBox strText, vbOKOnly, "Error"
Else
' it worked, read the xml here
End If
End If
End Sub