Instead of having this information show up as a message box, how can I modify the code so that that data is inputted into Sheet1.Range("A1")? Any help is greatly appreciated.
Sub Demo()
With CreateObject("Msxml2.XMLHTTP")
.Open "GET", "http://www.realtytrac.com/property" & Sheet1.Range("J11"), False
.setRequestHeader "DNT", "1"
.Send
MsgBox Split(Split(.responseText, "itemprop='propertyID'>")(1), "<")(0)
End With
End Sub
Sub Demo()
With CreateObject("Msxml2.XMLHTTP")
.Open "GET", "http://www.realtytrac.com/property" & Sheet1.Range("J11"), False
.setRequestHeader "DNT", "1"
.Send
val = Split(Split(.responseText, "itemprop='propertyID'>")(1), "<")(0)
ThisWorkbook.Sheets(1).Range("A1").value = val
End With
End Sub
If you have a valid response in your XMLHTTP object you should be able to use the following:
Sub Demo()
With CreateObject("Msxml2.XMLHTTP")
.Open "GET", "http://www.realtytrac.com/property" & Sheet1.Range("J11"), False
.setRequestHeader "DNT", "1"
.Send
ThisWorkbook.Sheets(1).Range("A1").Value = Split(Split(.responseText, "itemprop='propertyID'>")(1), "<")(0)
End With
End Sub
Related
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
Please help to give some hints for if i want to get a picture from a web site. Some code has been write but cannot get the right picture.
Sub get_pic()
With CreateObject("InternetExplorer.Application")
.Visible = True
.Navigate "https://igtb.bochk.com/index_tc.html"
Do While .busy
DoEvents
Loop
Do Until .readystate = 4
DoEvents
Sleep 2000
Loop
Set aaa = .document.all.tags("iframe")(1).contentwindow.document.all.tags("img")
For j = 0 To aaa.Length - 1
With CreateObject("MSXML2.XMLHTTP.6.0")
[a1] = aaa(j).href
.Open "GET", aaa(j).href, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.Send
strFilename = "C:\test.png"
ByteToFile .responsebody, strFilename
End With
Exit For
Next
End With
End Sub
Function ByteToFile(arrByte, strFilename)
With CreateObject("Adodb.Stream")
.Type = 1 'adTypeBinary
.Open
.Write arrByte
.SaveToFile strFilename, 2 'adSaveCreateOverWrite
.Close
End With
End Function
i know that will be change when you open any new request but is that any way to get the original picture when you open that page?
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
I'm trying to create a script in vba using ServerXMLHTTP60 to parse the title of the first post from some identical links. My main goal here is to make the script asynchronous along with setting a highest time up to which the script will try before going for the next url.
However, the macro that I've created always goes for the next url when there is a timeout without being able to scrape the titles from the links.
Sub FetchContentWithinSpecificTime()
Dim oHttp As New ServerXMLHTTP60, HTML As New HTMLDocument
Dim URL As Variant, Urllist As Variant, t As Date, sResp As Boolean
Urllist = Array( _
"https://stackoverflow.com/questions/tagged/web-scraping?tab=newest&page=1", _
"https://stackoverflow.com/questions/tagged/web-scraping?tab=newest&page=2", _
"https://stackoverflow.com/questions/tagged/web-scraping?tab=newest&page=3", _
"https://stackoverflow.com/questions/tagged/web-scraping?tab=newest&page=4", _
"https://stackoverflow.com/questions/tagged/web-scraping?tab=newest&page=5" _
)
For Each URL In Urllist
Debug.Print "trying with: " & URL
With oHttp
.Open "GET", URL, True
.setRequestHeader "User-Agent", "Mozilla/5.0"
.setTimeouts 5000, 5000, 15000, 15000
.send
t = Now + TimeValue("00:00:10")
sResp = False
On Error Resume Next
Do
If .readyState = 4 Then sResp = True: Exit Do
If Now > t Then sResp = False: Exit Do
DoEvents
Loop
On Error GoTo 0
If sResp Then
HTML.body.innerHTML = .responseText
Debug.Print HTML.querySelector(".question-hyperlink").innerText
Else:
Debug.Print "failed with: " & URL
End If
End With
Next URL
End Sub
How can I make a script wait for a certain time for the titles to parse before going for the next url?
I don't know why those SO links take to long to respond but I tried with different urls and the following solution appears to be working in the right way. The credit for the rectified portion goes to the provider of this solution.
Sub FetchContentWithinSpecificTime()
Dim oHttp As New ServerXMLHTTP60, HTML As New HTMLDocument
Dim URL As Variant, Urllist As Variant, t As Date
Dim sPrice$, sResp As Boolean
Urllist = Array( _
"https://finance.yahoo.com/quote/NZDUSD=X?p=NZDUSD=X", _
"https://finance.yahoo.com/quote/FB?p=FB", _
"https://finance.yahoo.com/quote/AAPL?p=AAPL", _
"https://finance.yahoo.com/quote/IBM?p=IBM", _
"https://finance.yahoo.com/quote/UCO?p=UCO" _
)
For Each URL In Urllist
Debug.Print "trying with: " & URL
With oHttp
.Open "GET", URL, True
.setRequestHeader "User-Agent", "Mozilla/5.0"
.send
t = Now + TimeValue("00:00:10")
sResp = False
Do While .readyState < 4
If .readyState = 4 Then Exit Do
sResp = (Now > t) Or (Err.Number <> 0)
If sResp Then Exit Do
DoEvents
Loop
If Not sResp Then
HTML.body.innerHTML = .responseText
sPrice = HTML.querySelector(".Mb\(-4px\)").innerText
Debug.Print sPrice
Else:
Debug.Print "failed with: " & URL
End If
End With
Next URL
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