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
Related
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
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
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
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
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