I have to create several functions that get the status of the supplied cargo number from each different website.
Below is the code user Zwenn helped me with. However, I am not familiar with the RegEx and Replace methods of VBA.
I am trying to simplify this code so I can replicate it for other websites. I understand that each website will need a unique code, but if the base stays the same and I can then modify the exact element needed to be scraped would be ideal.
Function FlightStat_AF(cargoNo As Variant) As String
Const url = "https://www.afklcargo.com/mycargo/api/shipment/detail/057-"
Dim elem As Object
Dim Result As String
Dim askFor As String
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", url & cargoNo, False
.send
Result = .responseText
If .Status = 200 Then
If InStr(1, Result, "faultDescription") = 0 Then
askFor = """metaStatus"""
Else
askFor = """faultDescription"""
End If
With CreateObject("VBScript.RegExp")
.Global = True
.MultiLine = True
.Pattern = askFor & ":(.*?),"
Set elem = .Execute(Result)
End With
Result = Replace(elem(0).SubMatches(0), Chr(34), "")
Else
Result = "No cargoID"
End If
End With
FlightStat_AF = Result
End Function
I am trying to create a similar function for the below website.
URL = https://booking.unitedcargo.com/skychain/app?service=page/nwp:Trackshipmt&doc_typ=AWB&awb_pre=016&awb_no=
Sample CargoNo = 60848034
The element to scrape is highlighted in yellow
The following should fetch you the required status as long as it is available.
Sub PrintStatus()
MsgBox GetDeliveryStat("60848034")
End Sub
Function GetDeliveryStat(cargoNo As Variant) As String
Const Url = "https://booking.unitedcargo.com/skychain/app?service=page/nwp:Trackshipmt&doc_typ=AWB&awb_pre=016&awb_no="
Dim dStatCheck$, deliveryStat$, S$
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", Url & cargoNo, False
.send
S = .responseText
End With
With CreateObject("HTMLFile")
.write S
On Error Resume Next
dStatCheck = .getElementById("trackShiptablerowInner0").getElementsByTagName("b")(0).innerText
On Error GoTo 0
If dStatCheck <> "" Then
deliveryStat = dStatCheck
Else
deliveryStat = "Not Found"
End If
End With
GetDeliveryStat = deliveryStat
End Function
Related
I've been successfully using the Yahoo Finance API cookie/crumb technique to get historical stock quotes for many years. On April 28th, 2022, it broke, and excessive exercise of vocabulary has failed to fix it.
The technique is to lookup an illegible stock symbol, because part of the returned cookie can be used to obtain real historical data on successive uses of the historical Yahoo API. I've tried it with illegible and legitimate stock symbols. I'm using Excel 2019 VBA, and the debug seems to hang on the ".waitForResponse (10)" instruction. It's part of a loop, and it hangs on the first instance. The code is shown below. It successfully writes a zero on ws1.S10, but it fails to do anything after the "Next cook" instruction. Did Yahoo intentionally break the Finance API again, or did Microsoft "improve" Excel? Or, more likely, did I do something stump stupid, like turn on the computer? Thanks!
Sub HistUp()
Dim resultFromYahoo, csv_rows() As String
Dim objRequest
Dim resultArray As Variant
Dim eagle, nColumns, cook, iRows, iCols As Integer
Dim CSV_Fields As Variant
Dim ticker, tickerURL, cookie, crumb As String
Dim HistQuote, HistDiv, DefaultKey As String
Dim Curr, StartPer As String
Dim fox, sheep, bear, elk, wolf, raccoon, snake As Integer
Dim julian, ricky, bubbles As Double
Dim crumbStartPos, crumbEndPos, Lastrow1, Lastrow2 As Long
Set wb = ThisWorkbook
Set ws1 = wb.Worksheets(1)
Set ws2 = wb.Worksheets(2)
Set ws3 = wb.Worksheets(3)
Set ws4 = wb.Worksheets(4)
Set ws5 = wb.Worksheets(5)
Application.EnableEvents = False
Application.DisplayAlerts = False
eagle = ActiveSheet.Index
wb.Worksheets("Warn").Select
wb.Worksheets("Warn").Range("A1").Select
DoEvents
'getCookieCrumb
For cook = 0 To 5 'ask for a valid crumb 6 times
ws1.Range("S10") = cook
Set objRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
With objRequest
.Open "GET", "https://finance.yahoo.com/lookup?s=turpitude", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
.send
.waitForResponse (10)
cookie = Split(.getResponseHeader("Set-Cookie"), ";")(0)
crumbStartPos = InStrRev(.ResponseText, """crumb"":""") + 9
crumbEndPos = crumbStartPos + 11
crumb = Mid(.ResponseText, crumbStartPos, crumbEndPos - crumbStartPos)
End With
If Len(crumb) = 11 Then 'a valid crumb is 11 characters long
Exit For
End If
Next cook
I have the same problem. Looks like Yahoo changed the Yahoo finance API.
When I comment out the line:
cookie = Split(.getResponseHeader("Set-Cookie"), ";")(0)
the code seems to work as before.
Then also comment out
'.setRequestHeader "Cookie", Cookie
when you send the request. Rest of my code:
'CONSTRUCT THE URL:
'interval=1d or 1wk or 1mo, events=dividends or events=history (prices) or events=splits
WebRequestURL = "https://query1.finance.yahoo.com/v7/finance/download/" & StockSymbol & _
"?period1=" & UnixStartDate & "&period2=" & UnixEndDate & _
"&interval=" & UrlInterval & "&events=" & UrlEvents & "&crumb=" & Crumb
'FETCH THE DATA:
With WebRequest
.Open "GET", WebRequestURL, False
'.setRequestHeader "Cookie", Cookie
.Send
.waitForResponse (10)
End With
As people have commented, the "Set-Cookie" header is no longer in the response, however the crumbstore is still there, so I would recommend checking to see if the header exists, and if not continue without setting that header or including the crumb.
Here is more robust code that allows you to select if you want price history, dividends, or split. You can also select a date range, by converting the dates to POSIX. It can also accommodate a proxy server. Feel free to comment on any improvements I can make to this code.
'New Yahoo Data Method
'sEvent: history, div, split
'sInterval: 1d,1wk,1mo
Public Function GetNewYahooData(sSymbol As String, sStart As String, sEnd As String, sEvent As String, sInterval As String, sProxy As String) As String
On Error GoTo Error_Message
Const sTestURL = "https://query1.finance.yahoo.com/v7/finance/download/"
Const sBaseURL = "https://finance.yahoo.com/quote/^GSPC"
'This assumes the crumb appears like this: "CrumbStore":{"crumb":"taEvjA8DFqs"}
Const sCrumbStart = """CrumbStore"":{""crumb"":"""
Const sCrumbEnd = """"
Const sTickerReplace = "TTTT"
Const sPeriod1Replace = "pppppppp"
Const sPeriod2Replace = "qqqqqqqq"
Const sEventReplace = "eeeeeeee"
Const sCrumbReplace = "cccccccc"
Const sIntervalReplace = "iiiiiiii"
Dim sReturn As String
Dim sTemURL As String
Dim sCookie As String
Dim sCrumb As String
Dim dtStart As Date
Dim dtEnd As Date
Dim lngCrumbStart As Long
Dim lngCrumbEnd As Long
Dim objRequest As WinHttp.WinHttpRequest
Dim sContentType As String
Dim bolHaveCrumb As Boolean
dtStart = CDate(sStart)
dtEnd = CDate(sEnd)
bolHaveCrumb = False
'Perform a Yahoo financial lookup on SP500 to get the crumb
Set objRequest = New WinHttp.WinHttpRequest
With objRequest
If Len(sProxy) > 0 Then .SetProxy 2, sProxy, ""
.Open "GET", sBaseURL, False
.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
.sEnd
.WaitForResponse (10)
sReturn = .ResponseText
If InStr(1, sReturn, sCrumbStart) > 0 Then
lngCrumbStart = InStr(1, sReturn, sCrumbStart) + 23
lngCrumbEnd = InStr(lngCrumbStart, sReturn, sCrumbEnd)
sCrumb = Mid(sReturn, lngCrumbStart, lngCrumbEnd - lngCrumbStart)
sCookie = .GetAllResponseHeaders
If InStr(sCookie, "Set-Cookie") > 0 Then
sCookie = Split(.GetResponseHeader("Set-Cookie"), ";")(0)
bolHaveCrumb = True
Else
bolHaveCrumb = False
End If
End If
End With
'This is currently https://query1.finance.yahoo.com/v7/finance/download/TTTT?period1=pppppppp&period2=qqqqqqqq&interval=iiiiiiii&events=eeeeeeee&crumb=cccccccc
sTemURL = gYAHOO_HIS_URL
sTemURL = Replace(sTemURL, sIntervalReplace, sInterval)
sTemURL = Replace(sTemURL, sTickerReplace, sSymbol)
sTemURL = Replace(sTemURL, sPeriod1Replace, toPOSIX(dtStart))
sTemURL = Replace(sTemURL, sPeriod2Replace, toPOSIX(dtEnd))
sTemURL = Replace(sTemURL, sEventReplace, sEvent)
If bolHaveCrumb Then
sTemURL = Replace(sTemURL, sCrumbReplace, sCrumb)
Else
sTemURL = Replace(sTemURL, "&" & sCrumbReplace, "")
End If
Set objRequest = New WinHttp.WinHttpRequest
With objRequest
If Len(sProxy) > 0 Then .SetProxy 2, sProxy, ""
.Open "GET", sTemURL, False
If bolHaveCrumb Then .SetRequestHeader "Cookie", sCookie
.sEnd
.WaitForResponse (10)
sContentType = .GetResponseHeader("Content-Type")
sReturn = StrConv(.ResponseText, vbUnicode)
sReturn = StrConv(sReturn, vbFromUnicode)
End With
If Len(sReturn) > 0 Then
GetNewYahooData = sReturn
Else
GetNewYahooData = ""
End If
Exit Function
Error_Message:
MsgBox err.Description, vbCritical, "Yahoo Price Retrieval"
GetNewYahooData = ""
End Function
'Helper function to convert a date into its POSIX representation
Public Function toPOSIX(dt As Date) As Long
On Error GoTo err
toPOSIX = DateDiff("s", "1/1/1970", dt)
Exit Function
err:
MsgBox err.Description, vbOKOnly, "toPOSIX"
End Function
Also sometimes the first time you make the request, it might not return anything, so I usually try 5 times before giving up.
'Sometimes we won't get a response on the first try, so try 5 times
While Not YahooEnd
gHTMLFileHis = GetNewYahooData(txtSymbol.Text, txtStartDate.Text, txtEndDate.Text, sEvent, sInterval, txtproxy.Text)
i = i + 1
If Len(gHTMLFileHis) = 0 Then
YahooSuccess = False
Else
arrRows = Split(gHTMLFileHis, vbLf)
arrRow = Split(arrRows(0), ",")
If arrRow(0) = StrConv("Date", vbUnicode) Or arrRow(0) = "Date" Then
YahooSuccess = True
YahooEnd = True
End If
If i = 5 Then YahooEnd = True
End If
Wend
I am trying to create a function that grabs the status of an airway bill by using a tracking number.
I have managed to create a function that grabs the status correctly with the help of the stackoverflow community.
However, I am trying to add in the error handling where the tracking number may be incorrect.
With the current function, it correctly gets the result if the tracking number is valid.
But when an incorrect number is provided, the function returns a 0 value and keeps running in a loop in the background. When stopped from the VBA editor, excel crashes.
This is the code I have come up with so far. Any help to add this error handling would be appreciated.
Sample Correct Cargo Number: 92366691
Sample Incorrect Cargo Number: 59473805
Function FlightStat_AF(cargoNo As Variant) As String
Dim url As String, ie As Object, result As String
url = "https://www.afklcargo.com/mycargo/shipment/detail/057-" & cargoNo
Set ie = CreateObject("InternetExplorer.Application")
With ie
.Visible = False
.navigate url
Do Until .readyState = 4: DoEvents: Loop
End With
'wait a little for dynamic content to be loaded
Application.Wait (Now + TimeSerial(0, 0, 1))
'Get the status from the table
Do While result = ""
DoEvents
On Error Resume Next
result = Trim(ie.document.getElementsByClassName("fs-12 body-font-bold")(1).innerText)
On Error GoTo 0
Application.Wait (Now + TimeSerial(0, 0, 1))
Loop
ie.Quit: Set ie = Nothing
'Return value of the function
FlightStat_AF = result
End Function
I learned a lot today and I'am very happy about that. My code based on this answer, I learned all the new things from^^
Scraping specific data inside a table II (Answer by SIM)
You ask about how to avoid an error when you send a wrong ID. Here is the answer how you can deal with that error and the error when you send an ID in the wrong format of an ID.
This is the Sub() to test the function:
Sub test()
'A valid ID
MsgBox FlightStat_AF("92366691")
'A wrong ID
'The whole string is "The provided AWB(s) is either invalid, not found or you are not authorized for it."
'The function FlightStat_AF cuts the string by comma
'So it delivers "The provided AWB(s) is either invalid"
'I'am not clear with regex till now and used it like the macro this code is based on ;-)
MsgBox FlightStat_AF("59473805")
'Somthing else than a valid ID format
MsgBox FlightStat_AF("blub")
End Sub
This is the function() to get the answer you want:
Function FlightStat_AF(cargoNo As Variant) As String
Const url = "https://www.afklcargo.com/mycargo/api/shipment/detail/057-"
Dim elem As Object
Dim result As String
Dim askFor As String
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", url & cargoNo, False
.send
result = .responseText
If .Status = 200 Then
If InStr(1, result, "faultDescription") = 0 Then
askFor = """metaStatus"""
Else
askFor = """faultDescription"""
End If
With CreateObject("VBScript.RegExp")
.Global = True
.MultiLine = True
.Pattern = askFor & ":(.*?),"
Set elem = .Execute(result)
End With
If Not elem Is Nothing Then
result = Replace(elem(0).SubMatches(0), Chr(34), "")
Else
result = "No Value"
End If
Else
result = "No cargoID"
End If
End With
FlightStat_AF = result
End Function
a way to check that the url is valid is to use the function below :
Public Function URLexist(urlToCheck As String) As Boolean
'source : https://excel-malin.com
On Error GoTo Err
Dim oXHTTP As Object
Set oXHTTP = CreateObject("MSXML2.XMLHTTP")
oXHTTP.Open "HEAD", urlToCheck , False
oXHTTP.send
URLexist = (oXHTTP.Status = 200)
Exit Function
Err:
URLexist = False
End Function
I've created a vba script to parse the title of diffetent posts along with the editing status of those posts from a website. What I wish to do now is let my script parse the title from it's landing page but print the title at the same time when it will print the editing status. I do not wish to create two subs for this task. I do not even know if it is possible in vba. However, if anything unclear please check out the comment within my script.
Sub ImportTitleFromAnotherLocation()
Const LINK$ = "https://stackoverflow.com/questions/tagged/web-scraping"
Const prefix$ = "https://stackoverflow.com"
Dim Http As New XMLHTTP60, Html As New HTMLDocument
Dim editInfo As Object, I&, targetUrl$, postTile$
With Http
.Open "GET", LINK, False
.send
Html.body.innerHTML = .responseText
End With
With Html.querySelectorAll(".summary .question-hyperlink")
For I = 0 To .Length - 1
postTitle = .item(I).innerText 'I like this line to be transferred to the location below
targetUrl = Replace(.item(I).getAttribute("href"), "about:", prefix)
With Http
.Open "GET", targetUrl, False
.send
Html.body.innerHTML = .responseText
End With
R = R + 1: Cells(R, 1) = postTitle 'here I wish to use the above line like this
Set editInfo = Html.querySelector(".user-action-time > a")
If Not editInfo Is Nothing Then
Cells(R, 2) = editInfo.innerText
End If
Next I
End With
End Sub
You are overwriting your html document in the loop. A simple way would be to use a second htmldocument variable. A more verbose way would be to store the titles before the loop, for example in an array during an additional loop, then use your i variable to index into that to retrieve each title during the existing loop.
Sub ImportTitleFromAnotherLocation()
Const LINK$ = "https://stackoverflow.com/questions/tagged/web-scraping"
Const prefix$ = "https://stackoverflow.com"
Dim Http As New XMLHTTP60, Html As New HTMLDocument, Html2 As New HTMLDocument
Dim editInfo As Object, I&, targetUrl$, postTile$
Dim postTitle As String, r As Long
With Http
.Open "GET", LINK, False
.send
Html.body.innerHTML = .responseText
End With
With Html.querySelectorAll(".summary .question-hyperlink")
For I = 0 To .Length - 1
postTitle = .item(I).innerText 'I like this line to be transferred to the location below
targetUrl = Replace$(.item(I).getAttribute("href"), "about:", prefix)
With Http
.Open "GET", targetUrl, False
.send
Html2.body.innerHTML = .responseText
End With
r = r + 1: ActiveSheet.Cells(r, 1) = postTitle 'here I wish to use the above line like this
Set editInfo = Html2.querySelector(".user-action-time > a")
If Not editInfo Is Nothing Then
ActiveSheet.Cells(r, 2) = editInfo.innerText
End If
Next I
End With
End Sub
I am trying to download non-free shipping charges from eBay. I have the item numbers of the pages. The links should go to the right pages on eBay.
While trying to go to the page and download the data, Excel hangs.
I have similar working code that gets the eBay item numbers on many pages from eBay.
If this code can't be fixed how can I get the info I need into Excel?
itemNumberAlone = Range("a" & eachItem).Value
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://www.ebay.com/itm/" & itemNumberAlone & "?ru=http%3A%2F%2Fwww.ebay.com%2Fsch%2Fi.html%3F_from%3DR40%26_sacat%3D0%26_nkw%3D" & itemNumberAlone & "%26_rdc%3D1" _
, Destination:=Range("$bZ$1"))
.Name = "second ebay links"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = True
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Do While Not IsError(Application.Match("Shipping and handling", Range("bz1:bz1000"), 0))
If IsError(Application.Match("Shipping and handling", Range("bz1:bz1000"), 0)) Then Exit Do
If Not IsError(Application.Match("Shipping and handling", Range("bz1:bz1000"), 0)) Then
shippingRow = Application.Match("Shipping and handling", Range("bz1:bz1000"), 0) + 1
shippingCell = Range("bz" & shippingRow).Value
If Left(shippingCell, 2) <> "US" Then
Range("bz" & shippingRow - 1).ClearContents
Else
Range("c" & eachItem).Value = Right(shippingCell, Len(shippingCell) - 2)
End If
End If
Loop
End If
Next
I think you will have to learn DOM automation to do this cleanly. I took a look at the HTML on the ebay pages and it might be a little much for someone who hasn't used DOM automation before. I wasn't planning on writing this but it sounds like you are in a bit of a pinch, so here you go. You can use it to learn from. Just keep in mind that this will work in the short-term but when they change their HTML, it will fail.
Option Explicit
Sub Get_Ebay_Shipping_Charges()
Dim IE As Object, DOM_DOC As Object
Dim URL$, SHIPPING_CHARGES$
Dim SHIPPING_AMOUNT
Dim i&, x&
Dim EL, EL_COLLECTION, CHILD_NODES, TABLE_NODES, TABLE_ROW_NODES, TABLE_DATA_NODES, ITEM_NUMBER_ARRAY
Dim WS As Excel.Worksheet
Dim ITEM_NOT_FOUND As Boolean
''You should change this to the worksheet name you want to use
''ie Set WS = ThisWorkbook.Sheets("Ebay")
Set WS = ThisWorkbook.Sheets(1)
''Create an Internet Explorer Object
Set IE = CreateObject("InternetExplorer.Application")
''Make it visible
IE.Visible = True
''You can replace this with an array that is built from your spreadsheet, this is just for demo purposes
ITEM_NUMBER_ARRAY = Array("290941626676", "130942854921", "400035340501")
''In your code, you can start your loop here to handle the list of items
''This code is a little different for demo purposes
For x = 0 To UBound(ITEM_NUMBER_ARRAY)
''Here is your URL
URL = "http://www.ebay.com/itm/" & ITEM_NUMBER_ARRAY(x) & "?ru=http%3A%2F%2Fwww.ebay.com%2Fsch%2Fi.html%3F_from%3DR40%26_sacat%3D0%26_nkw%3D" & ITEM_NUMBER_ARRAY(x) & "%26_rdc%3D1"
''Navigate to your URL
IE.navigate URL
''This loop will wait until the page is received from the server - the page was hanging for me too so I added a counter to exit after a certain number of loops (this is the i variable)
Do Until IE.readystate = 4 Or i = 50000
i = i + 1
DoEvents
Loop
i = 0
''This sets the DOM document
Set DOM_DOC = IE.document
''First get a collection of table names
Set EL_COLLECTION = DOM_DOC.GetElementsByTagName("table")
If IsEmpty(EL_COLLECTION) Then ITEM_NOT_FOUND = True: GoTo ERR_EXIT
''Then look for the table classname that matches the one we want (in this case "sh-tbl") and set the childnodes to a new collection
For Each EL In EL_COLLECTION
If EL.ClassName = "sh-tbl" Then
Set CHILD_NODES = EL.ChildNodes
Exit For
End If
Next EL
If IsEmpty(CHILD_NODES) Then ITEM_NOT_FOUND = True: GoTo ERR_EXIT
''Next look for the TBODY element in the childnodes collection and set the childnodes of the TBODY element when found
For Each EL In CHILD_NODES
If Not TypeName(EL) = "DispHTMLDOMTextNode" Then
If EL.tagname = "TBODY" Then
Set TABLE_NODES = EL.ChildNodes
Exit For
End If
End If
Next EL
If IsEmpty(TABLE_NODES) Then ITEM_NOT_FOUND = True: GoTo ERR_EXIT
''Find the TR element and set its childnodes to another collection
For Each EL In TABLE_NODES
If Not TypeName(EL) = "DispHTMLDOMTextNode" Then
If EL.tagname = "TR" Then
Set TABLE_ROW_NODES = EL.ChildNodes
Exit For
End If
End If
Next EL
If IsEmpty(TABLE_ROW_NODES) Then ITEM_NOT_FOUND = True: GoTo ERR_EXIT
''Find the first TD element and get it's childnodes
For Each EL In TABLE_ROW_NODES
If Not TypeName(EL) = "DispHTMLDOMTextNode" Then
If EL.tagname = "TD" Then
Set TABLE_DATA_NODES = EL.ChildNodes
Exit For
End If
End If
Next EL
If IsEmpty(TABLE_DATA_NODES) Then ITEM_NOT_FOUND = True: GoTo ERR_EXIT
''The first DIV element holds the shipping information so when it is found, get the innertext of that element
For Each EL In TABLE_DATA_NODES
If Not TypeName(EL) = "DispHTMLDOMTextNode" Then
If EL.tagname = "DIV" Then
SHIPPING_CHARGES = EL.INNERTEXT
Exit For
End If
End If
Next EL
''Make sure a shipping charge was found
If SHIPPING_CHARGES = vbNullString Then MsgBox "No shipping charges found for item " & ITEM_NUMBER_ARRAY(x): GoTo ERR_EXIT
If IsNumeric(Right(SHIPPING_CHARGES, InStr(SHIPPING_CHARGES, Chr(36)))) Then
SHIPPING_AMOUNT = Right(SHIPPING_CHARGES, InStr(SHIPPING_CHARGES, Chr(36)))
Else
SHIPPING_AMOUNT = SHIPPING_CHARGES
End If
''You may have to change this to fit your spreadsheet
WS.Cells(x + 1, 3).Value = SHIPPING_AMOUNT
ERR_EXIT:
If ITEM_NOT_FOUND = True Then MsgBox "No Page Was Found For Item " & ITEM_NUMBER_ARRAY(x): ITEM_NOT_FOUND = False
Next x
IE.Quit
Set IE = Nothing
End Sub
If you are stuck on using your existing code, you can also try deleting the querytables after the query.
Dim QRY_TABLE As QueryTable
For Each QRY_TABLE In ThisWorkbook.Sheets(1).QueryTables
QRY_TABLE.Delete
Next
This method will not delete the querytable values on your spreadsheet but it will kill the querytable connection. If you have too many of these, it could create a crash.
One final suggestion, if your workbook contains a lot of vlookups then this is probably the true culprit. Good Luck!
You can use xmlHTTP object which will download the data easier and wont make the excel stuck.
Sub xmlHttp()
Dim xmlHttp As Object
Set xmlHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
Dim ITEM_NUMBER_ARRAY As Variant
ITEM_NUMBER_ARRAY = Array("290941626676", "130942854921", "400035340501")
For x = 0 To UBound(ITEM_NUMBER_ARRAY)
''Here is your URL
URL = "http://www.ebay.com/itm/" & ITEM_NUMBER_ARRAY(x) & "?ru=http%3A%2F%2Fwww.ebay.com%2Fsch%2Fi.html%3F_from%3DR40%26_sacat%3D0%26_nkw%3D" & ITEM_NUMBER_ARRAY(x) & "%26_rdc%3D1"
xmlHttp.Open "GET", URL, False
xmlHttp.setRequestHeader "Content-Type", "text/xml"
xmlHttp.send
Dim html As Object
Set html = CreateObject("htmlfile")
html.body.innerHTML = xmlHttp.ResponseText
Set objShipping = html.getelementbyid("shippingSection").getElementsbytagname("td")(0)
If Not objShipping Is Nothing Then
Set divShip = objShipping.ChildNodes(1)
Debug.Print divShip.innerHTML
Else
Debug.Print "No Data"
End If
Next
End Sub
Immediate Window (Ctrl + G)
US $2.55
No Data
US $6.50
I would like to direct an excel VBA form to certain URLs, get the HTML source and store that resource in a string. Is this possible, and if so, how do I do it?
Yes. One way to do it is to use the MSXML DLL - and to do that you need to add a reference to the Microsoft XML library via Tools->References.
Here's some code that displays the content of a given URL:
Public Sub ShowHTML(ByVal strURL)
On Error GoTo ErrorHandler
Dim strError As String
strError = ""
Dim oXMLHTTP As MSXML2.XMLHTTP
Set oXMLHTTP = New MSXML2.XMLHTTP
Dim strResponse As String
strResponse = ""
With oXMLHTTP
.Open "GET", strURL, False
.send ""
If .Status <> 200 Then
strError = .statusText
GoTo CleanUpAndExit
Else
If .getResponseHeader("Content-type") <> "text/html" Then
strError = "Not an HTML file"
GoTo CleanUpAndExit
Else
strResponse = .responseText
End If
End If
End With
CleanUpAndExit:
On Error Resume Next ' Avoid recursive call to error handler
' Clean up code goes here
Set oXMLHTTP = Nothing
If Len(strError) > 0 Then ' Report any error
MsgBox strError
Else
MsgBox strResponse
End If
Exit Sub
ErrorHandler:
strError = Err.Description
Resume CleanUpAndExit
End Sub
Just an addition to the above response. The question was how to get the HTML source which the stated answer does not actually provide.
Compare the contents of oXMLHTTP.responseText with the source code in a browser for URL "http://finance.yahoo.com/q/op?s=T+Options". They do not match and even the returned values are different. (This should be executed after hours to avoid changes during the trading day.)
If I find a way to perform this task the basic code will be posted.
Compact getHTTP function
Below is a compact & generic function that will return HTTP response from a specified URL to, for example:
return the HTML Source of a web page,
JSON response from an API URL,
parse a text file at a URL, etc.
This does not require any VBA References since MSXML2 is used as a late-bound object.
Public Function getHTTP(ByVal url As String) As String
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", url, False: .Send
getHTTP = StrConv(.responseBody, vbUnicode)
End With
End Function
Note that this basic function has no validation or error handling, as those are the parts that can vary considerably depending on which URL you're hitting.
If desired, check the value of .Status after the .Send) to check for success codes like 0 or 200, and also you can setup an error trap with On Error Goto... (never Resume Next!)
Example Usage:
This procedure scrapes this Stack Overflow page for the current score of this question.
Sub demo_getVoteCount()
Const answerID$ = 2522760
Const url_SO = "https://stackoverflow.com/a/" & answerID
Dim html As String, startPos As Long, voteCount As Variant
html = getHTTP(url_SO) 'get html from url
startPos = InStr(html, "answerid=""" & answerID) 'locate this answer
startPos = InStr(startPos, html, "vote-count-post") 'locate vote count
startPos = InStr(startPos, html, ">") + 1 'locate value
voteCount=Mid(html,startPos,InStr(startPos,html,"<")-startPos) 'extract score
MsgBox "Answer #" & answerID & " has a score of " & voteCount & "."
End Sub
Of course in reality there are far better ways to get the score of an answer than the example above, such as this way.)