How can I make this work now? I'm trying to get the value from Column Y (rng1) and also the value from Column Z (rng2)
Dim xhr As Object, thisRequest As String, rng1 As Range, rng2 As Range
Set xhr = CreateObject("Microsoft.XMLHTTP")
With ThisWorkbook.Worksheets("Fulcrum Upload")
For Each rng1 In .Range("Y3:Y" & .Cells(.Rows.Count, "Y").End(xlUp).Row).SpecialCells(xlVisible)
For Each rng2 In .Range("Z3:Z" & .Cells(.Rows.Count, "Z").End(xlUp).Row).SpecialCells(xlVisible)
If Not IsEmpty(rng1) Then
With xhr
.Open "PUT", "https://api.fulcrumapp.com/api/v2/records/" + rng2 + ".json", False
.setRequestHeader "Accept", "application/json"
.setRequestHeader "Content-type", "application/json"
.setRequestHeader "X-ApiToken", "11111111"
.send rng1.value
End With
End If
Next
End With
I think you want to use offset to grab the adjacent value and thereby only need one loop. And use & to concantenate string.
With ThisWorkbook.Worksheets("Fulcrum Upload")
For Each rng1 In .Range("Y3:Y" & .Cells(.Rows.Count, "Y").End(xlUp).Row).SpecialCells(xlVisible)
If Not IsEmpty(rng1) Then
With xhr
.Open "PUT", "https://api.fulcrumapp.com/api/v2/records/" & rng1.Offset(, 1).Value & ".json", False
.setRequestHeader "Accept", "application/json"
.setRequestHeader "Content-type", "application/json"
.setRequestHeader "X-ApiToken", "11111111"
.send rng1.Value
End With
End If
Next
End With
End Sub
Related
I would like to download the Json file from google drive using VBA.
Sub downloadGAS()
Dim winhttp As Object
Set winhttp = CreateObject("winhttp.winhttprequest.5.1")
Dim sURL As String
sURL = "https://script.google.com/feeds/download/export?id=1u848Q8cABNHjoQ42c8twAaS6SWtrn3NMxUKFsz4TQ6Q_e6rcv-eCpfZe&format=json"
With winhttp
.Open "GET", sURL, False
.setRequestHeader "Content-Type", "text/html; charset=UTF-8"
.send
debug.print .responseText
End With
End Sub
Json content:
{"files":[
{"id":"2169dc1e-202d-4558-b982-eb70c1336de4",
"name":"appsscript",
"type":"json",
"source":"{\n \"timeZone\": \"Asia/Hong_Kong\",\n \"dependencies\": {\n },\n \"exceptionLogging\": \"STACKDRIVER\",\n \"runtimeVersion\": \"V8\"\n}"},
{"id":"d27d6560-847f-46ba-87a4-af2a2a7d9ff6",
"name":"Code",
"type":"server_js",
"source":"function myFunction() {\n console.log(\"success\")\n}\n"}
]}
There is a function in the GAS json which is:
function myFunction() {
console.log("success")
}
Is it possible to ensure winhttp responseText to include the GAS json code, so I can keep the response in a text file.
Thank you for your help.
I'm not sure I understand what you're trying to achieve? But if you just want to save the responseText, then use the function that way.
Sub downloadGAS()
Dim winhttp As Object
Set winhttp = CreateObject("winhttp.winhttprequest.5.1")
Dim objStream: Set objStream = CreateObject("ADODB.Stream")
objStream.Charset = "utf-8"
Dim sURL As String
sURL = "https://script.google.com/feeds/download/export?id=1u848Q8cABNHjoQ42c8twAaS6SWtrn3NMxUKFsz4TQ6Q_e6rcv-eCpfZe&format=json"
With winhttp
.Open "GET", sURL, False
.setRequestHeader "Content-Type", "text/html; charset=UTF-8"
.send
objStream.Open
objStream.WriteText .responseText
objStream.SaveToFile "C:\path2file\google_app.json", 2
Set objStream = Nothing
' Debug.Print .responseText
End With
End Sub
I want to extract the following items from a single website response to an Excel sheet:
Value of one of the cookies.
A value of an ID from the body of the response.
Cookie value to capture:
ID value to capture from HTML body:
I have searched for the solution, but I can find a way to pull a cookie separately with a different code and the id value separately from the HTML response body through another code.
However, combining the codes doesn't work as I need to use the same cookie value and the id value from the response in the subsequent post request.
To make the flow easier to understand, I will summarise my expectation below:
Visit "Site 1" grab the "Cookie" value and unique "ID" value from the response.
Pass the two values received in the previous response to the request of "Site 2".
Grab the link from the response of "Site 2" and visit "Site 3".
The code I have used to receive cookie values and HTML body content, which throws an error if uncommenting the codes to pull HTML body content. Kindly let me know where I am making a mistake or try a new way. (I have tried different way around, so I have kept them as comments.)
Sub Cookie_and_HTMLbody()
Dim strCookie As Variant
Dim strToken As Variant
Dim Doc As Object
Dim pontod As Object
'Dim Elements As IHTMLElementCollection
'Dim Element As IHTMLElement
On Error Resume Next
Set Doc = New HTMLDocument
With CreateObject("WinHttp.WinHttpRequest.5.1")
'With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://example.com", False
.setRequestHeader "Upgrade-Insecure-Requests", "1"
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/90.0.4430.85 Safari/537.36"
.setRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/avif,image/webp,image/apng,*/*;q=0.8,application/signed-exchange;v=b3;q=0.9"
.setRequestHeader "Sec-Fetch-Site", "none"
.setRequestHeader "Sec-Fetch-Mode", "navigate"
.setRequestHeader "Sec-Fetch-User", "?1"
.setRequestHeader "Sec-Fetch-Dest", "document"
.setRequestHeader "Accept-Encoding", "gzip, deflate"
.setRequestHeader "Accept-Language", "en-US,en;q=0.9"
.setRequestHeader "Connection", "close"
.send
Doc.body.innerHTML = .responseText
Set pontod = Doc.getElementById("trialrequestlanding").getElementsByTagName("div")(1).getElementsByTagName("div")(1).getElementsByTagName("div")(1).getElementsByTagName("div")(1).getElementsByTagName("form")(1).getElementsByTagName("div")(1).getElementsByTagName("input")(1)
strCookie = .getAllResponseHeaders
'strCookie = .getResponseHeader("Set-Cookie:")
'strCookie = Split(strCookie, "Set-Cookie:")
'strCookie = Trim(strCookie(UBound(strCookie)))
strCookie = Split(strCookie, vbCrLf)
strCookie = Trim(Split(Split(strCookie(5), ";")(0), ":")(1)) & "; " & Trim(Split(Split(strCookie(6), ";")(0), ":")(1))
MsgBox strCookie
'.responseType = document
'Doc = .responseText
strToken = pontod.getAttribute("value")
'strToken = Doc.querySelector("input[name='RequestVerificationToken']").getAttribute("value")
'strToken = document.getElementsByTagName("input")
'Set Doc = ie.document
MsgBox strToken
'Set Elements = .getElementsByTagName("input")
'For Each Element In Elements
' If Element.ID = "RequestVerificationToken" Then
'Range("c2").Value = Element.innerText
' MsgBox Element.Value
' End If
'Next Element
'Set Elements = Nothing
'Doc.Quit
'Set Doc = Nothing
End With
End Sub
Another code that works for retrieving a value from the HTML body is given below.
Sub Generate_Email()
Dim Shell As Object
Dim i As Variant
Dim bie As Object
Dim ie As Object
Dim Doc As HTMLDocument
Dim Elements As IHTMLElementCollection
Dim Element As IHTMLElement
'Set ie = New InternetExplorerMedium
Set ie = CreateObject("InternetExplorer.Application")
'Set ie = GetObject("new:{D5E8041D-920F-45e9-B8FB-B1DEB82C6E5E}")
'Set ie = New InternetExplorer
ie.Visible = False
ie.navigate "https://randomsite.com/"
Do
DoEvents
Loop Until ie.readyState = 4
'Do While ie.Busy Or ie.readyState <> 4
'DoEvents
'Loop
Set Doc = ie.document
Set Elements = Doc.getElementsByTagName("span")
For Each Element In Elements
If Element.ID = "email_ch_text" Then
Range("c2").Value = Element.innerText
End If
Next Element
Set Elements = Nothing
ie.Visible = True
ie.Quit
Set ie = Nothing
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * From Win32_Process")
On Error Resume Next
For Each objItem In colItems
'msgbox objItem.name & " " & objItem.ProcessID & " " & objItem.CommandLine
If objItem.Name = "ielowutil.exe" Then objItem.Terminate
Next
For Each objItem In colItems
'msgbox objItem.name & " " & objItem.ProcessID & " " & objItem.CommandLine
If objItem.Name = "iexplore.exe" Then objItem.Terminate
Next
End Sub
How to retrieve both the values using a single code?
UPDATE (02 May 2021):
I have rewritten the code that supports extracting cookie properly but has an issue with pulling the element attribute "value", as shown in image 2.
Kindly help me to identify what mistake blocks me from extracting the element attribute in the below code.
Sub Test_Cookie_and_HTML()
Dim pontod As Object
Dim html As Object
On Error Resume Next
Set html = New HTMLDocument
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "GET", "https://portswigger.net/burp/pro/trial", False
.setRequestHeader "Upgrade-Insecure-Requests", "1"
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/90.0.4430.85 Safari/537.36"
.setRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/avif,image/webp,image/apng,*/*;q=0.8,application/signed-exchange;v=b3;q=0.9"
.setRequestHeader "Sec-Fetch-Site", "none"
.setRequestHeader "Sec-Fetch-Mode", "navigate"
.setRequestHeader "Sec-Fetch-User", "?1"
.setRequestHeader "Sec-Fetch-Dest", "document"
.setRequestHeader "Accept-Encoding", "gzip, deflate"
.setRequestHeader "Accept-Language", "en-US,en;q=0.9"
.setRequestHeader "Connection", "close"
.send
html.body.innerHTML = .responseText
Dim strCookie As String
Dim sessionidCookie As String
strCookie = .getResponseHeader("Set-Cookie") ' --> "SESSIONID=40DD2DFCAF24A2D64544F55194FCE04E;path=/pamsservices;HttpOnly"
sessionidCookie = GetsessionIdCookie(strCookie) ' Strips to "SESSIONID=40DD2DFCAF24A2D64544F55194FCE04E"
MsgBox sessionidCookie
MsgBox RequestVerificationToken
End With
Set pontod = html.getElementById("trialrequestlanding").getElementsByTagName("input")(1)
MsgBox pontod.getAttribute("value")
End Sub
My JSON response:
{"type":"FeatureCollection","totalFeatures":1,"features":[{"type":"Feature","id":"pand3d.6317078","geometry":{"type":"Polygon","coordinates":[[[125290.418,479247.512,0],[125289.696,479248.817,0],[125287.842,479247.791,0],[125264.136,479234.672,0],[125262.123,479233.558,0],[125262.675,479232.56,0],[125281.04,479199.376,0],[125281.226,479199.039,0],[125283.611,479200.359,0],[125286.739,479202.09,0],[125287.237,479202.366,0],[125289.944,479203.864,0],[125290.547,479204.198,0],[125299.388,479209.09,0],[125299.965,479209.409,0],[125302.747,479210.949,0],[125303.148,479211.171,0],[125306.787,479213.185,0],[125308.799,479214.298,0],[125308.765,479214.36,0],[125290.418,479247.512,0]]]},"geometry_name":"geovlak","properties":{"gid":6317078,"identificatie":"0363100012148538","aanduidingrecordinactief":false,"aanduidingrecordcorrectie":0,"officieel":false,"inonderzoek":false,"documentnummer":"GV00000406","documentdatum":"2010-09-09Z","bouwjaar":"2005-01-01Z","begindatumtijdvakgeldigheid":"2010-09-08T22:00:00Z","einddatumtijdvakgeldigheid":null,"gemeentecode":"0363","ground-0.00":-3.64,"ground-0.10":-0.9,"ground-0.20":-0.89,"ground-0.30":-0.88,"ground-0.40":-0.88,"ground-0.50":-0.87,"roof-0.25":27.52,"rmse-0.25":1.09,"roof-0.50":27.57,"rmse-0.50":1.09,"roof-0.75":29.91,"rmse-0.75":1.08,"roof-0.90":30.24,"rmse-0.90":1.08,"roof-0.95":30.35,"rmse-0.95":1.08,"roof-0.99":30.36,"rmse-0.99":1.08,"roof_flat":false,"nr_ground_pts":3515,"nr_roof_pts":6432,"ahn_file_date":"2014-02-01T23:00:00Z","ahn_version":3,"height_valid":true,"tile_id":"25gz2","bbox":[125262.123,479199.039,125308.799,479248.817]}}],"crs":{"type":"name","properties":{"name":"urn:ogc:def:crs:EPSG::28992"}},"bbox":[125262.123,479199.039,125308.799,479248.817]}
I want to parse ["roof-0.99":30.36] from the {properties} object, which is in an array [features], but getting an error of "Invalid arguments"
Here is my attempt
Sub BAG3D()
Dim ws As Worksheet: Set ws = Blad1
'Variabeles for function
Dim BAG3D As Object
Dim objHTTP As Object
Set objHTTP = CreateObject("MSXML2.XMLHTTP")
objHTTP.Open "GET", "http://3dbag.bk.tudelft.nl/data/wfs?SERVICE=WFS&REQUEST=GetFeature&TYPENAMES=BAG3D:pand3d&CQL_FILTER=identificatie=%270363100012148538%27&outputFormat=json", False
' objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
' objHTTP.setRequestHeader "Accept", "application/hal+json"
' objHTTP.setRequestHeader "Content-type", "application/x-www-form-urlencoded"
' objHTTP.setRequestHeader "X-Api-Key", KEY
objHTTP.send
Set BAG3D = ParseJson(objHTTP.responseText)
Debug.Print objHTTP.responseText
For Each Item In BAG3D("features")(0)("0")("properties")
'Look for "roof-0.99" and get value
ws.Range("Y3").Value = BAG3D("roof-0.99") 'probably not right
Next
End Sub
What should I modify in my parser to properly parse this roof-0.99 into my spreadsheet?
Sub BAG3D()
Dim ws As Worksheet: Set ws = Blad1
'Variabeles for function
Dim BAG3D As Object
Dim objHTTP As Object
Set objHTTP = CreateObject("MSXML2.XMLHTTP")
objHTTP.Open "GET", "http://3dbag.bk.tudelft.nl/data/wfs?SERVICE=WFS&REQUEST=GetFeature&TYPENAMES=BAG3D:pand3d&CQL_FILTER=identificatie=%270363100012148538%27&outputFormat=json", False
' objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
' objHTTP.setRequestHeader "Accept", "application/hal+json"
' objHTTP.setRequestHeader "Content-type", "application/x-www-form-urlencoded"
' objHTTP.setRequestHeader "X-Api-Key", KEY
objHTTP.send
Set BAG3D = ParseJson(objHTTP.responseText)
Debug.Print objHTTP.responseText
ws.Range("Y3").Value = BAG3D("features")(1)("properties")("roof-0.99")
End Sub
I have developed a code to scrape data from a website but since I know very little about JSON I could be able to get the output as required shown in below snap:
However, I am getting all data from the web in the immediate window but want to organize these fields just like an above snap.
Here is my code:
Sub FetchTabularInfo()
Dim Http As New XMLHTTP60, Html As New HTMLDocument
Dim col As Variant, icol As New Collection
Dim csrf As Variant, I&
With Http
.Open "GET", "https://ngodarpan.gov.in/index.php/home/statewise_ngo/76/35/1", False
.send
Html.body.innerHTML = .responseText
End With
With Html.querySelectorAll(".table tr a[onclick^='show_ngo_info']")
For I = 0 To .Length - 1
icol.Add Split(Split(.Item(I).getAttribute("onclick"), "(""")(1), """)")(0)
Next I
End With
For Each col In icol
With Http
.Open "GET", "https://ngodarpan.gov.in/index.php/ajaxcontroller/get_csrf", False
.send
csrf = .responseText
End With
csrf = Split(Replace(Split(csrf, ":")(1), """", ""), "}")(0)
With Http
.Open "POST", "https://ngodarpan.gov.in/index.php/ajaxcontroller/show_ngo_info", False
.setRequestHeader "X-Requested-With", "XMLHttpRequest"
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
.send "id=" & col & "&csrf_test_name=" & csrf
End With
Debug.Print Http.responseText
Next col
End Sub
The output in the immediate window is:
The following shows you how to use a json parser. I use jsonconverter.bas. After copying the code from there into a standard module called JsonConverter, you need to go VBE>Tools>References>Add reference to Microsoft Scripting Runtime.
In the json response the {} are dictionaries accessed by key; the [] are collections accessed by index (or For Each over)
Option Explicit
Public Sub FetchTabularInfo()
Dim Http As New XMLHTTP60, Html As New HTMLDocument
Dim col As Variant, icol As New Collection
Dim csrf As Variant, i&
With Http
.Open "GET", "https://ngodarpan.gov.in/index.php/home/statewise_ngo/76/35/1", False
.send
Html.body.innerHTML = .responseText
End With
With Html.querySelectorAll(".table tr a[onclick^='show_ngo_info']")
For i = 0 To .Length - 1
icol.Add Split(Split(.item(i).getAttribute("onclick"), "(""")(1), """)")(0)
Next i
End With
Dim r As Long, headers(), results(), ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
headers = Array("SrNo", "Name of VGO/NGO", "Address", "City", "State", "Tel", "Mobile", "Web", "Email")
ReDim results(1 To icol.Count, 1 To UBound(headers) + 1)
For Each col In icol
r = r + 1
With Http
.Open "GET", "https://ngodarpan.gov.in/index.php/ajaxcontroller/get_csrf", False
.send
csrf = .responseText
End With
csrf = Split(Replace(Split(csrf, ":")(1), """", ""), "}")(0)
Dim json As Object
With Http
.Open "POST", "https://ngodarpan.gov.in/index.php/ajaxcontroller/show_ngo_info", False
.setRequestHeader "X-Requested-With", "XMLHttpRequest"
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
.send "id=" & col & "&csrf_test_name=" & csrf
Set json = JsonConverter.ParseJson(.responseText)
Dim orgName As String, address As String, srNo As Long, city As String
Dim state As String, tel As String, mobile As String, website As String, email As String
On Error Resume Next
orgName = json("registeration_info")(1)("nr_orgName")
address = json("registeration_info")(1)("nr_add")
city = json("registeration_info")(1)("nr_city")
srNo = r '<unsure where this is coming from.
state = Replace$(json("registeration_info")(1)("StateName"), "amp;", vbNullString)
tel = IIf(IsNull(json("infor")("0")("Off_phone1")), vbNullString, json("infor")("0")("Off_phone1")) '<unsure where this is coming from. Need a csrf to test with
mobile = json("infor")("0")("Mobile")
website = json("infor")("0")("ngo_url")
email = json("infor")("0")("Email")
On Error GoTo 0
Dim arr()
arr = Array(srNo, orgName, address, city, state, tel, mobile, website, email)
For i = LBound(headers) To UBound(headers)
results(r, i + 1) = arr(i)
Next
End With
Next col
With ws
.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
.Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
End With
End Sub
What i'm trying to accomplish is to go through a specific Table Column and for each visible row return the value of that cell. This cell contains a formula that creates a JSON from values in the table in other columns. Here's an example of the column i want to loop through:
Json Output
Inside this loop i'm going to use each cell value and POST the JSON, but it needs to loop through and post for each cell in that columnn. Here is the VBA code I'm using to POST a single cell without the loop:
Sub FulcrumUpload()
Dim xhr As Object, thisRequest As String, JSONvalue As String
Set xhr = CreateObject("Microsoft.XMLHTTP")
thisRequest = "https://api.fulcrumapp.com/api/v2/records.json"
xhr.Open "POST", thisRequest, False
xhr.setRequestHeader "Accept", "application/json"
xhr.setRequestHeader "Content-type", "application/json"
xhr.setRequestHeader "X-ApiToken", "11111111111111"
xhr.Send Sheets("Fulcrum Upload").Range("V3").value
End Sub
Assuming your filtered data is in column V, from V3 onwards, perhaps something like:
Public Sub FulcrumUpload()
Dim xhr As Object, thisRequest As String, rng As Range
Set xhr = CreateObject("Microsoft.XMLHTTP")
thisRequest = "https://api.fulcrumapp.com/api/v2/records.json"
With ThisWorkbook.Worksheets("Fulcrum Upload")
For Each rng In .Range("V3:V" & .Cells(.Rows.Count, "V").End(xlUp).Row).SpecialCells(xlVisible)
If Not IsEmpty(rng) Then
With xhr
.Open "POST", thisRequest, False
.setRequestHeader "Accept", "application/json"
.setRequestHeader "Content-type", "application/json"
.setRequestHeader "X-ApiToken", "11111111111111"
.send rng.Value
End With
End If
Next
End With
End Sub