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
Related
I'm trying to access a soap webservice via classic asp over https, but I get the following error.
MSXML3.DLL error '800c000e'
A security problem occurred.
My code:
Function GetASPNetResources()
Dim returnString
Dim myXML
Dim objRequest
Dim objXMLDoc
Dim strXmlToSend
Dim webserviceurl
Dim webserviceSOAPActionNameSpace
strXmlToSend = "<some valid xml>"
webserviceurl = "https://webserviceurl"
webserviceSOAPActionNameSpace = "appname"
Set objRequest = Server.createobject("MSXML2.XMLHTTP.3.0")
objRequest.open "POST", webserviceurl, False
objRequest.setRequestHeader "Content-Type", "application/soap+xml"
objRequest.setRequestHeader "CharSet", "utf-8"
objRequest.setRequestHeader "action", webserviceSOAPActionNameSpace & "GetEstimate"
objRequest.setRequestHeader "SOAPAction", webserviceSOAPActionNameSpace & "GetEstimate"
Set objXMLDoc = Server.createobject("MSXML2.DOMDocument.3.0")
objXMLDoc.loadXml strXmlToSend
objRequest.Send()
Response.Write objXMLDoc.load(objRequest.responseXML)
End Function
Did you google for that error ?
SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS = 13056
objRequest.setOption 2, SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS
I need to make status message on excel after calling the api . status message in xml format so how to parse the data accurately.
Below given codes are using to get API info
Sub Test()
Dim xmlHTTP As Object
Set xmlHTTP = CreateObject("MSXML2.ServerXMLHTTP.6.0")
myURL = "http://xxxxxxxxxxxxx:15555/gateway/StatusTracking/1.0/shipment/tracking?housebill=cvvvv"
xmlHTTP.Open "GET", myURL, False
xmlHTTP.SetRequestHeader "APIKey", "xxxx-xxx-xxxxx-xxxx-xxxx"
xmlHTTP.SetRequestHeader "Accept", "application/json"
xmlHTTP.Send
Dim strReap As String
strReap = hReq.ResponseText
Dim xmlDoc As New MSXML2.DOMDocument
If Not xmlDoc.LoadXML(strReap) Then
MsgBox "Load error"
End If
Dim xnodelist As MSXML2.IXMLDOMNodeList
Set xnodelist = xmlDoc.getElementsByTagName("ShipmentTracking")
Dim xnode As MSXML2.IXMLDOMNode Set xnode = xnodelist.Item(0)
Dim obAtt1 As MSXML2.IXMLDOMAttribute
Dim obAtt2 As MSXML2.IXMLDOMAttribute
Dim xChild As MSXML2.IXMLDOMNode
Dim intRow As Integer
intRow = 2
Dim strCol1 As String
strCol1 = "A"
Dim strCol2 As String
strCol1 = "B"
Dim Shipment As String
For Each xChild In xnode.ChildNodes
Set obAtt1 = xChild.Attributes.getNamedItem("Shipment")
ws.Cells(intRow, 2) = obAtt1
intRow = intRow + 1
Next xChild
Set hReq = Nothing
Set xmlDoc = Nothing
End Sub
normal xml status message format given below
<Shipment tracking>
<type/>
<object/>
<properties/>
<Shipment>
<Origin/>
<type/>
<properties/>
<LocationCode/>
<CountryCode/>
</Shipment>
</Shipment tracking>
I am newbie in vba programming and i tried with this code but not working fine. I just want output,from shipment(xmltagname) to end in excel sheet. Please help me on this
You have written code Attributes.getNamedItem when in fact you have no attributes. Also to query for elements I'd prefer selectNodes and selectSingleNode instead of getElementsByTagName.
So try
xChild.selectSingleNode("Shipment")
and change the declaration for the receiving variable from IXMLDOMAttribute to IXMLDOMElement
I've acquires an old VBScript that was used to retrived test score that I'm trying to convert to a VB.net Form app.
I'm stuck with this function
Function getit()
Dim xmlhttp
Dim pageNum
Dim objStream
Dim objDebugStream
Set objStream = CreateObject("ADODB.Stream")
objStream.Type = 1 'adTypeBinary
pageNum = 1
Do While pageNum > 0
Set xmlhttp=CreateObject("MSXML2.ServerXMLHTTP")
'strURL = DownloadDest
Wscript.Echo "Download-URL: " & strURL & "&page_num=" & pageNum
'For basic auth, use the line below together with user+pass variables above
xmlhttp.Open "GET", strURL & "&page_num=" & pageNum, false
xmlhttp.Send
Wscript.Echo "Download-Status: " & xmlhttp.Status & " " & xmlhttp.statusText
If xmlhttp.Status = 200 Then
If Left(LCase(xmlhttp.responseText),16) <> "no records found" Then
If objStream.State = 0 Then
objStream.Open
End If
objStream.Write xmlhttp.responseBody
If debugEachPage Then
Set objDebugStream = CreateObject("ADODB.Stream")
objDebugStream.Type = 1 'adTypeBinary
objDebugStream.Open
objDebugStream.Write xmlhttp.responseBody
objDebugStream.SaveToFile ".\sortest_aleks_" & classCode & "_page_" & pageNum & ".csv"
objDebugStream.Close
Set objDebugStream = Nothing
End If
Else
If pageNum = 1 Then
WScript.Echo "No Records Found for " & classCode
End If
pageNum = 0 ' Have to set this to exit loop
End If
Else
WScript.Echo "Response Status of " & xmlhttp.Status & " for " & classCode
End If
If pageNum <> 0 Then
pageNum = pageNum + 1
End If
Set xmlhttp=Nothing
Loop
If objStream.State <> 0 Then
objStream.SaveToFile LocalFile
objStream.Close
End If
Set objStream = Nothing
End Function
What I wrote looks like this
Private Sub GetALEKSData(ByVal strURL As String)
REM ======================================================================================================
' This Module will access the ALEKS Web Site and access the CofC foreign language scores for the terms indicated days
' The Comma Seperated Values (CSV) as then stored in the main form Text Box
'=========================================================================================================
Dim ALEKStr As System.IO.Stream = Nothing
Dim srRead As System.IO.StreamReader = Nothing
Try
'Create a WebReq for the URL
Dim WebReq As System.Net.WebRequest = System.Net.HttpWebRequest.Create(strURL)
'If required by the server, set the credentials.
WebReq.Credentials = CredentialCache.DefaultNetworkCredentials
'Get the Respponse.
Dim WebResp As System.Net.WebResponse = WebReq.GetResponse
' Display the status.
' If required by the server, set the credentials.
ALEKStr = WebResp.GetResponseStream
srRead = New System.IO.StreamReader(ALEKStr)
' read all the text
TextBox1.Text = srRead.ReadToEnd
Catch ex As Exception
TextBox1.Text = QQ REM Wipe Text box to indicate No DATA to Process
Finally
' Close Stream and StreamReader when done
srRead.Close()
ALEKStr.Close()
End Try
Debug.Print(TextBox1.Text)
REM Remove NO Data message
If InStr(TextBox1.Text, "No records match criteria.") > 0 Then TextBox1.Text = QQ
DataFileHasData = Len(TextBox1.Text) > 0
End Sub
It is returning with :Access denied: wrong3 HTTP header from
Not sure what I'm missing
Try this:
Private Sub GetALEKSData(ByVal strURL As String)
REM ======================================================================================================
' This Module will access the ALEKS Web Site and access the CofC foreign language scores for the terms indicated days
' The Comma Seperated Values (CSV) as then stored in the main form Text Box
'=========================================================================================================
Using wc As New System.Net.WebClient()
Try
wc.Credentials = CredentialCache.DefaultNetworkCredentials
TextBox1.Text = wc.DownloadString(strURL)
Catch
TextBox1.Text = QQ
End Try
End Using
Debug.Print(TextBox1.Text)
If TextBox1.Text.Contains("No records match criteria.") Then TextBox1.Text = QQ
DataFileHasData = Not String.IsNullorWhiteSpace(TextBox1.Text)
End Sub
And if that doesn't work, the error message says, "Access Denied", so the problem is probably this line:
wc.Credentials = CredentialCache.DefaultNetworkCredentials
If that still doesn't help, install fiddler and compare the HTTP requests sent by the old vbscript to the new VB.Net code. You'll be able to see exactly what you're missing.
Setting the UserAgent fixed the issue
Private Sub GetWEBData(ByVal strURL As String)
REM ======================================================================================================
' This Module will access the WEB Web Site and access the CofC foreign language scores for the terms indicated days
' The Comma Seperated Values (CSV) as then stored in the main form Text Box
'=========================================================================================================
'Clear existing data
Try
'Create a WebReq for the URL
Dim WebReq As HttpWebRequest = CType(WebRequest.Create(strURL), HttpWebRequest)
'If required by the server, set the credentials.
WebReq.Credentials = CredentialCache.DefaultNetworkCredentials
WebReq.UserAgent = "Mozilla/5.0 (Windows NT 6.1) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/41.0.2228.0 Safari/537.36"
'Get the Respponse.
'Dim WebResp As System.Net.WebResponse = WebReq.GetResponse
Dim WebResp As HttpWebResponse = CType(WebReq.GetResponse(), HttpWebResponse)
' Display the status.
' Console.WriteLine(WebResp.StatusDescription)
' Open the stream using a StreamReader for easy access.
Dim WEBtream As Stream = WebResp.GetResponseStream()
' Open the stream using a StreamReader for easy access.
Dim srRead As New StreamReader(WEBtream)
' Read the content.
Dim responseFromServer As String = srRead.ReadToEnd()
' Display the content.
TextBox1.Text = responseFromServer
TextBox1.Refresh()
'Console.WriteLine(responseFromServer)
' Cleanup the streams and the response.
srRead.Close()
WEBtream.Close()
WebResp.Close()
Catch ex As Exception
MsgBox("WEB DATA READ ERROR OCCURED", MsgBoxStyle.Critical, "Program Error")
End Try
End Sub
first time posting,
I'm trying to get the ID "dadosDoUsuario" from a website's page I have to be logged in. I got it working using "InternetExplorer.Application" object, but can't get the ID value when using "MSXML2.XMLHTTP" object. It seems it won't go past the login page, since I'm able to get other IDs from this page (example: "tituloPagina"). Could someone give a hint on how I get the data from the page after logged in? Thanks!
InternetExplorer.Application code (this one works):
Sub testIE()
Dim texto As String
Set ie = CreateObject("InternetExplorer.Application")
my_url = "https://www.nfp.fazenda.sp.gov.br/login.aspx"
With ie
.Visible = False
.Navigate my_url
Do Until Not ie.Busy And ie.readyState = 4
DoEvents
Loop
End With
ie.Document.getelementbyid("userName").Value = "MYUSERNAME"
ie.Document.getelementbyid("Password").Value = "MYPASSWORD"
ie.Document.getelementbyid("Login").Click
Do Until Not ie.Busy And ie.readyState = 4
DoEvents
Loop
ie.Document.getelementbyid("btnConsultarNFSemestre").Click
Do Until Not ie.Busy And ie.readyState = 4
DoEvents
Loop
texto = ie.Document.getelementbyid("dadosDoUsuario").innerText
MsgBox texto
ie.Quit
End Sub
MSXML2.XMLHTTP code (this one doesn't work):
Sub testXMLHTTP()
Dim xml As Object
Dim html As Object
Dim dados As Object
Dim text As Object
Set xml = CreateObject("MSXML2.XMLHTTP")
Set html = CreateObject("htmlFile")
With xml
.Open "POST", "https://www.nfp.fazenda.sp.gov.br/Login.aspx", False
.setRequestHeader "Content-Type", "text/xml"
.send "userName=MYUSERNAME&password=MYPASSWORD"
.Open "GET", "https://www.nfp.fazenda.sp.gov.br/Inicio.aspx", False
.setRequestHeader "Content-Type", "text/xml"
.send
End With
html.body.innerhtml = xml.responseText
Set objResult = html.GetElementById("dadosDoUsuario")
GetElementById = objResult.innertext
MsgBox GetElementById
End Sub
EDIT: I followed the steps suggested by #Florent B., and added a scripcontrol to get the encoded values for __VIEWSTATE, __VIEWSTATEGENERATOR and __EVENTVALIDATION. Got it working!
Sub testXMLHTTP()
Dim xml As Object
Dim html As HTMLDocument
Dim dados As Object
Dim text As Object
Dim html2 As HTMLDocument
Dim xml2 As Object
Set xml = CreateObject("Msxml2.ServerXMLHTTP.6.0")
Set html = CreateObject("htmlFile")
With xml
.Open "GET", "https://www.nfp.fazenda.sp.gov.br/Login.aspx", False
.send
End With
strCookie = xml.getResponseHeader("Set-Cookie")
html.body.innerhtml = xml.responseText
Set objvstate = html.GetElementById("__VIEWSTATE")
Set objvstategen = html.GetElementById("__VIEWSTATEGENERATOR")
Set objeventval = html.GetElementById("__EVENTVALIDATION")
vstate = objvstate.Value
vstategen = objvstategen.Value
eventval = objeventval.Value
'URL Encode ViewState
Dim ScriptEngine As ScriptControl
Set ScriptEngine = New ScriptControl
ScriptEngine.Language = "JScript"
ScriptEngine.AddCode "function encode(vstate) {return encodeURIComponent(vstate);}"
Dim encoded As String
encoded = ScriptEngine.Run("encode", vstate)
vstate = encoded
'URL Encode Event Validation
ScriptEngine.AddCode "function encode(eventval) {return encodeURIComponent(eventval);}"
encoded = ScriptEngine.Run("encode", eventval)
eventval = encoded
'URL Encode ViewState Generator
ScriptEngine.AddCode "function encode(vstategen) {return encodeURIComponent(vstategen);}"
encoded = ScriptEngine.Run("encode", vstategen)
vstategen = encoded
Postdata = "__EVENTTARGET=" & "&__EVENTARGUMENT=" & "&__VIEWSTATE=" & vstate & "&__VIEWSTATEGENERATOR=" & vstategen & "&__EVENTVALIDATION=" & eventval & "&ctl00$ddlTipoUsuario=#rdBtnNaoContribuinte" & "&ctl00$UserNameAcessivel=Digite+o+Usuário" & "&ctl00$PasswordAcessivel=x" & "&ctl00$ConteudoPagina$Login1$rblTipo=rdBtnNaoContribuinte" & "&ctl00$ConteudoPagina$Login1$UserName=MYUSERNAME" & "&ctl00$ConteudoPagina$Login1$Password=MYPASSWORD" & "&ctl00$ConteudoPagina$Login1$Login=Acessar" & "&ctl00$ConteudoPagina$Login1$txtCpfCnpj=Digite+o+Usuário"
Set xml2 = CreateObject("Msxml2.ServerXMLHTTP.6.0")
Set html2 = CreateObject("htmlFile")
With xml2
.Open "POST", "https://www.nfp.fazenda.sp.gov.br/Login.aspx", False
.setRequestHeader "Cookie", strCookie
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "Content-Lenght", Len(Postdata)
.send (Postdata)
End With
html2.body.innerhtml = xml2.responseText
Set objResult = html2.GetElementById("dadosDoUsuario")
GetElementById = objResult.innertext
MsgBox GetElementById
End Sub
It's possible but not that easy.
First you need to use CreateObject("Msxml2.ServerXMLHTTP.6.0") and not CreateObject("MSXML2.XMLHTTP").
Then follow these steps:
Open and send a GET to https://www.nfp.fazenda.sp.gov.br/login.aspx
Parse and store the cookie from the response header "Set-Cookie"
Parse and store the __VIEWSTATE, __VIEWSTATEGENERATOR, __EVENTVALIDATION from the HTML response
Build the data for the next query with the values parsed previously and with your user-name/password :
__EVENTTARGET:""
__EVENTARGUMENT:""
__VIEWSTATE:"..."
__VIEWSTATEGENERATOR:"..."
__EVENTVALIDATION:"..."
ctl00$ddlTipoUsuario:"#rdBtnNaoContribuinte"
ctl00$UserNameAcessivel:"Digite+o+Usuário"
ctl00$PasswordAcessivel:"x"
ctl00$ConteudoPagina$Login1$rblTipo:"rdBtnNaoContribuinte"
ctl00$ConteudoPagina$Login1$UserName:"..."
ctl00$ConteudoPagina$Login1$Password:"..."
ctl00$ConteudoPagina$Login1$Login:"Acessar"
ctl00$ConteudoPagina$Login1$txtCpfCnpj:"Digite+o+Usuário"
Open a POST to https://www.nfp.fazenda.sp.gov.br/login.aspx
Set the header "Cookie" with the cookie parsed at step 2
Set the header Content-Type: "application/x-www-form-urlencoded"
Set the header Content-Length with the length of the data
Send the POST with the data from step 4
I'm trying to download the XML data outputted by Google Map API. After I download and store that data in a variable, I would like to parse that data to get a specific information. Here is the link to a sample output : http://maps.googleapis.com/maps/api/geocode/xml?latlng=34.6465583799,-101.57620022
Dim oXMLHTTP As Object
Dim sPageHTML As String
Dim sURL As String
Dim XmlMapResponse As String
sURL = "http://maps.googleapis.com/maps/api/geocode/xml?latlng=" + Selection.Value
Set oXMLHTTP = CreateObject("MSXML2.ServerXMLHTTP")
oXMLHTTP.Open "GET", sURL, False
oXMLHTTP.send
XmlMapResponse = oXMLHTTP.responseText
Once the XML data has been downloaded, I tried to parse out "79088" which is the postal code by doing this :
Dim strXML As String
Dim xNode As IXMLDOMNode
Dim XDoc As MSXML2.DOMDocument
strXML = XmlMapResponse
Set XDoc = New MSXML2.DOMDocument
If Not XDoc.LoadXML(strXML) Then
Err.Raise XDoc.parseError.ErrorCode, , XDoc.parseError.reason
End If
Set xNode = XDoc.SelectNodes("/GeocodeResponse/result/address_component/long_name")
MsgBox xNode.InnerText(6)
I don't know why xNode.InnerText(6) doesn't work for me. In VB.NET it works fine.
Any help?
SelectNodes returns a node list, not a single node.
Maybe you meant to use:
Set xNode = XDoc.SelectNodes( _
"/GeocodeResponse/result/address_component/long_name")(6)
As previously mentioned SelectNodes returns a node list which caused an error when I attempted to run this code.You should either:
change xNode to a IXMLDOMNodeList
Select only a single node from the list (as suggested by Tim)
Change the function to XDoc.selectSingleNode("/XPATH")
Beyond that, The IXMLDOMNode Object does not appear to support an InnerText function. use xNode.Text instead.
The following code runs without errors and returns the first result (8379)
Sub test()
Dim oXMLHTTP As Object
Dim sPageHTML As String
Dim sURL As String
Dim XmlMapResponse As String
sURL = "http://maps.googleapis.com/maps/api/geocode/xml?latlng=" + "34.6465583799,-101.57620022"
Set oXMLHTTP = CreateObject("MSXML2.ServerXMLHTTP")
oXMLHTTP.Open "GET", sURL, False
oXMLHTTP.send
XmlMapResponse = oXMLHTTP.responseText
Dim strXML As String
Dim xNode As MSXML2.IXMLDOMNode
Dim XDoc As MSXML2.DOMDocument60
strXML = XmlMapResponse
Set XDoc = New MSXML2.DOMDocument60
If Not XDoc.LoadXML(strXML) Then
Err.Raise XDoc.parseError.ErrorCode, , XDoc.parseError.reason
End If
Set xNode = XDoc.SelectSingleNode("/GeocodeResponse/result/address_component/long_name")
MsgBox xNode.Text
End Sub