the code below doesn't save the data, usually after 24 loops. why might that be? thank you.
Public Sub XmlHttpTutorial()
For x = 1 To 50
Dim xmlhttp As New MSXML2.XMLHTTP60, myurl As String
myurl = "https://www.etsy.com/shop/SilverHandwriting/reviews?page=" & x
xmlhttp.Open "GET", myurl, False
xmlhttp.send
Sheets("sayfa1").Cells(x, "a") = xmlhttp.responseText
Next x
End Sub
Related
I try to get a list of actions from iAuditor filtered by "template_id" by sending an HTTP Request with VBA. For the moment I have this code that return the list of all actions:
Sub Get_Data()
Dim hReq As Object
Dim sht As Worksheet
Dim authKey As String
Dim response As String
authKey = "d8a0df7d7e1XXXXXXXXXXXXXXXXXXXXXXXXff3c765cf2fcf"
Set sht = Sheets(1)
Dim strUrl As String
strUrl = "https://api.safetyculture.io/tasks/v1/actions/list"
Set hReq = CreateObject("MSXML2.XMLHTTP")
With hReq
.Open "POST", strUrl, False
.SetRequestHeader "Authorization", "Bearer " & authKey
.SetRequestHeader "Content-Type", "application/json"
.Send
End With
response = hReq.ResponseText
'MsgBox Len(response)
sht.Range("A1") = response
End Sub
Now I want to "translate" a filter to VBA but I have no idea how to do it.
Here is my API Documentation about the website : https://developer.safetyculture.io/#actions
So what i want to translate in VBA looks like this in HTTP code i guess :
curl -X POST "https://api.safetyculture.io/tasks/v1/actions/list" \
-H "Authorization: Bearer {api_token}" \
-d {
"template_id": {
"operator": 7,
"value": ["fc2e53f6-4712-4ca5-b681-aba3ac954217"]
}
}
I thank You a lot for any help you can offer me.
Regards,
Gabin
According to this thread:
https://www.vbforums.com/showthread.php?592624-Posting-data-using-XMLHttpRequest
you can add Data to a POST Request by passing it as a value in the send function:
hReq.send "'template_id': {'operator': 7,'value': ['fc2e53f6-4712-4ca5-b681-aba3ac954217']}"
Values are differentiated by a & Symbol inside the string.
I've did it !!! :D
Here is my final code:
Sub Get_Data()
Dim hReq As Object
Dim sht As Worksheet
Dim authKey As String
Dim response As String
Dim response_objet As Object
Dim Body As String
authKey = "d8a0df7d7e19XXXXXXXXXXXXXXXXc65ec9eff3c765cf2fcf"
Body = "{ ""filters"": [ { ""template_id"": { ""value"": [""884b95df35104f4792a3c1fdfed63f0e""]}}]}"
Set sht = Sheets(1)
sht.Range("A3") = Body
Dim strUrl As String
strUrl = "https://api.safetyculture.io/tasks/v1/actions/list"
Set hReq = CreateObject("MSXML2.XMLHTTP")
With hReq
.Open "POST", strUrl, False
.SetRequestHeader "Authorization", "Bearer " & authKey
.SetRequestHeader "Content-Type", "application/json"
.Send Body
End With
response = hReq.ResponseText
'MsgBox Len(response)
sht.Range("A1") = response
Set response_objet = JsonConverter.ParseJson(response)
For Each Item In response_objet
a = a + 1
Sheets("Biblio").Range("B" & a) = Item
Next Item
End Sub
Huge thanks to #CodingWolf , he put me on the right direction.
Have a nice day internet.
Gabin,
Good day,
I am struggling to proceed further from this, so with some research, I managed to this point and now i am stuck.
I need assistance to load the data into EXCEL as a datatable.
Here is my code.
Sub MDM_API_CALL()
Dim hReq As Object
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim strUrl As String
strUrl = "url to request bearer token"
Set hReq = CreateObject("MSXML2.ServerXMLHTTP.6.0")
With hReq
.Open "POST", strUrl, False
.Send
End With
Dim response As String
response = hReq.responseText
authKey = Mid(response, 11, Len(Mid(response, 11, Len(response) - 12)))
strUrl = "url that requests the data in CSV format"
Set hReq = CreateObject("MSXML2.XMLHTTP")
With hReq
.Open "GET", strUrl, False
.SetRequestHeader "Authorization", "Bearer " & authKey
.Send
End With
response = hReq.responseText
ws.Range("A1").Value = response
End Sub
After the code, the data is saved in cell A1 and my data is cropped due to the cell limit.
Thank you
Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 5 years ago.
Improve this question
I am struggling to understand how I can call a specific variable and organize it in an excel worksheet.
I need to get the buy, sell and vol from this url https://api.blinktrade.com/api/v1/BRL/ticker?crypto_currency=BTC but I am not able to find out how to separate it.
I am using this code to call the data
Public Sub btcteste()
'Dim xmlhttp As Object
Dim xmlhttp As New MSXML2.ServerXMLHTTP60
Set xmlhttp = CreateObject("MSXML2.serverXMLHTTP")
Dim myurl As String
myurl = "https://api.blinktrade.com/api/v1/BRL/ticker?crypto_currency=BTC"
xmlhttp.Open "GET", myurl, False
xmlhttp.send
MsgBox (xmlhttp.responseText)
End Sub
And it is working but how can I separate the variables and paste it in single cells?
Thanks
Public Sub btcteste()
Dim xmlhttp As Object
'Dim xmlhttp As New MSXML2.ServerXMLHTTP60
Set xmlhttp = CreateObject("MSXML2.serverXMLHTTP")
Dim myurl As String
myurl = "https://api.blinktrade.com/api/v1/BRL/ticker?crypto_currency=BTC"
xmlhttp.Open "GET", myurl, False
xmlhttp.send
Dim data As Variant
data = xmlhttp.responseText
Debug.Print data
' example data
' {"high": 13400.0, "vol": 616.03500983, "buy": 12830.59, "last": 12899.78, "low": 11800.0, "pair": "BTCBRL", "sell": 12899.78, "vol_brl": 7808332.67293126}
' split at comma (,) , and then split at colon (:)
data = Split(data, ",") ' convert to array
ActiveWorkbook.Sheets("Sheet1").Range("b2:b4") = Application.Transpose(Array("buy", "sell", "vol"))
' buy, sell and vol
ActiveWorkbook.Sheets("Sheet1").Range("c2") = Split(data(2), ":")(1) ' buy
ActiveWorkbook.Sheets("Sheet1").Range("c3") = Split(data(6), ":")(1) ' sell
ActiveWorkbook.Sheets("Sheet1").Range("c4") = Split(data(1), ":")(1) ' vol
End Sub
Try this code.
Public Sub btcteste()
Dim xmlhttp As Object
'Dim xmlhttp As New MSXML2.ServerXMLHTTP60
Set xmlhttp = CreateObject("MSXML2.serverXMLHTTP")
Dim myurl As String
Dim strText As String
Dim vSplit As Variant, v As Variant
Dim vR() As Variant
Dim n As Integer
myurl = "https://api.blinktrade.com/api/v1/BRL/ticker?crypto_currency=BTC"
xmlhttp.Open "GET", myurl, False
xmlhttp.send
'MsgBox (xmlhttp.responseText)
strText = xmlhttp.responseText
strText = Replace(strText, "}", "")
strText = Replace(strText, "{", "")
strText = Replace(strText, Chr(34), "")
vSplit = Split(strText, ",")
For Each v In vSplit
n = n + 1
ReDim Preserve vR(1 To 2, 1 To n)
vR(1, n) = Trim(Split(v, ":")(0))
vR(2, n) = Trim(Split(v, ":")(1))
Next v
Range("a1").Resize(n, 2) = WorksheetFunction.Transpose(vR) '<~~ this is vertical
'Range("a1").Resize(2, n) = vR '<~~ this is horisontal
End Sub
My intention is to scrape all the app name from that page and the app link leading to the next page. However, when i run it, i see that after looping once it produces the following error "Run time error 91, object variable or with block variable not set".Here is the full code. Any help would really be appreciated. Thanks in advance.
Sub app_crawler()
Dim xmlpage As New XMLHTTP60, htmldoc As New HTMLDocument
Dim htmlas As Object, htmla As Object, sstr As String
xmlpage.Open "GET", "https://itunes.apple.com/us/app/candy-crush-saga/id553834731?mt=8", False
xmlpage.send
htmldoc.body.innerHTML = xmlpage.responseText
For Each htmlas In htmldoc.getElementsByClassName("lockup-info")(0).getElementsByTagName("a")
sstr = htmlas.href
xmlpage.Open "GET", sstr, False
xmlpage.send
htmldoc.body.innerHTML = xmlpage.responseText
For Each htmla In htmldoc.getElementsByClassName("intro")(1).getElementsByTagName("h1")
x = x + 1: Cells(x, 1) = htmla.innerText
Next htmla
Next htmlas
End Sub
As Mat's Mug commented, you'll have to test if htmlas(x) returns Nothing before getting elements from it, and the same applies for getElementByTagName and others:
Sub TestSth()
Dim xmlpage As New MSXML2.XMLHTTP60
Dim htmldoc As New MSHTML.HTMLDocument
Dim htmlas As Object, gist As Object
Dim htmla As Object, main As Object, lux As String
Dim x As Long, link As Object, thank As Object
Range("A1").Select
xmlpage.Open "GET", "https://itunes.apple.com/us/app/candy-crush-saga/id553834731?mt=8", False
xmlpage.send
htmldoc.body.innerHTML = xmlpage.responseText
Set xmlpage = Nothing
Set htmlas = htmldoc.getElementsByClassName("lockup-info")
For x = 0 To htmlas.Length - IIf(htmlas.Length > 0, 1, 0)
If Not htmlas(x) Is Nothing Then
If Not htmlas(x).getElementsByTagName("a") Is Nothing Then
If Not htmlas(x).getElementsByTagName("a")(0) Is Nothing Then
lux = htmlas(x).getElementsByTagName("a")(0).getAttribute("href")
If lux <> "" Then
xmlpage.Open "GET", lux, False
xmlpage.send
htmldoc.body.innerHTML = xmlpage.responseText
Set main = htmldoc.getElementsByClassName("intro")(1)
Set thank = main.getElementsByTagName("div")
For Each link In thank
ActiveCell.Value = link.innertext
ActiveCell.Offset(1, 0).Select
Next link
End If
End If
End If
End If
Next x
End Sub
This is the answer which fixes all the problems I was having:
Sub app_crawler()
Dim http As New XMLHTTP60, hdoc As New HTMLDocument, hdoc_one As New HTMLDocument
Dim elem As Object, post As Object, sstr As String
With http
.Open "GET", "https://itunes.apple.com/us/app/candy-crush-saga/id553834731?mt=8", False
.send
hdoc.body.innerHTML = .responseText
End With
For Each elem In hdoc.getElementsByClassName("lockup-info")
With elem.getElementsByTagName("li")(0).getElementsByTagName("a")
If .Length Then sstr = .Item(0).href
End With
With http
.Open "GET", sstr, False
.send
hdoc_one.body.innerHTML = .responseText
End With
For Each post In hdoc_one.getElementsByClassName("intro")
With post.getElementsByTagName("h1")
If .Length Then i = i + 1: Cells(i, 1) = .Item(0).innerText
End With
Next post
Next elem
End Sub
I have code like below. And I receive error
"run-time error '-2146697211 *800c0005)'': the system cannot locate the resource specified"
I do not know how to solve it thanks in advance for any help. Line in which error is handled is httpRequest.send
Function pullSomeSite(urlcheck As String) As Boolean
Dim httpRequest As xmlhttp
Set httpRequest = New xmlhttp
Dim URL As String
URL = urlcheck
With httpRequest
.Open "POST", URL, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send !!!!!!here code stops!!!!!!!
End With
With httpRequest
While Not .readyState = 4 '<---------- wait
Application.Wait Now + TimeValue("0:00:01")
Wend
'Debug.Print .Status
If .Status = 200 Then
While InStr(1, .responseText, "Updating", 0) > 0 '<---------- wait again
Application.Wait Now + TimeValue("0:00:01")
Wend
pullSomeSite = True
Else
pullSomeSite = False
End If
End With
End Function
Test this :
Sub Test_URLExists()
Dim url As String
url = "http://stackoverflow.com/questions/33940044/url-check-in-vba-error"
MsgBox url, vbInformation, URLExists(url)
url = "http://stackoverflow.com/questions/12345678/url-check-in-vba-error"
MsgBox url, vbInformation, URLExists(url)
End Sub
here is how to test an URL with a function :
Function URLExists(url As String) As Boolean
Dim Request As Object
Dim ff As Integer
Dim rc As Variant
URLExists = False
On Error GoTo EndNow
Set Request = CreateObject("WinHttp.WinHttpRequest.5.1")
With Request
.Open "GET", url, False
.Send
rc = .StatusText
End With
Set Request = Nothing
If rc = "OK" Then URLExists = True
Exit Function
EndNow:
End Function
Instead of xmlhttp data type use object.
Use the below code.
. You need to give input as "http://google.com"
Sub test1()
a = pullSomeSite("http://www.flipkart.com")
MsgBox a
End Sub
Function pullSomeSite(urlcheck As String) As Boolean
Dim httpRequest As Object
Set httpRequest = CreateObject("MSXML2.XMLHTTP")
'Set httpRequest = New xmlhttp
Dim URL As String
URL = urlcheck
With httpRequest
.Open "POST", URL, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send '!!!!!!here code stops!!!!!!!
End With
With httpRequest
While Not .readyState = 4 '<---------- wait
Application.Wait Now + TimeValue("0:00:01")
Wend
'Debug.Print .Status
If .Status = 200 Then
While InStr(1, .responseText, "Updating", 0) > 0 '<---------- wait again
Application.Wait Now + TimeValue("0:00:01")
Wend
pullSomeSite = True
Else
pullSomeSite = False
End If
End With
End Function