I've a VBA script which download files from a website but when the PDF file is being downloaded and when I tried to save it to my local drive of the system I'm getting an error called run time error '3004': Write to file failed. My code is as following:
Sub login()
Dim objIE As InternetExplorer
Dim uid As String
Dim pwd As String
Dim rng As Range
Dim sh As Worksheet
Dim objCollection As Object
Dim buttonCollection As Object
Dim ieElement As Object
Dim ieButton As Object
Dim WinHttpReq As Object
Dim oStream As Object
Dim MyURL As String
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
Set sh = Sheets("Indeed Resume Download")
Set rng = sh.Range("A2")
uid = rng.Value
pwd = rng.Offset(0, 1).Value
Dim j As Long
Set objIE = New InternetExplorer 'Initialize internet object
objIE.Navigate "https://secure.indeed.com/account/login?service=my&hl=en_IN&co=IN&continue=https%3A%2F%2Fwww.indeed.co.in%2F"
objIE.Visible = True
objIE.Document.all.signin_email.Value = uid
objIE.Document.all.signin_password.Value = pwd
Set ieElement = objIE.Document.getElementsByClassName("sg-btn sg-btn-primary btn-signin")(0)
ieElement.Click
For j = 2 To sh.Cells(Rows.Count, 27).End(xlUp).Row
Set objIE = New InternetExplorer
objIE.Visible = True
MyURL = sh.Range("XDA" & j).Value
objIE.Navigate MyURL
Do While objIE.Busy = True
DoEvents
Loop
Set ieButton = objIE.Document.getElementsByClassName("button download_button"(0)
ieButton.Click
WinHttpReq.Open "GET", MyURL, False
WinHttpReq.Send
MyURL = WinHttpReq.responseBody
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.SaveToFile ("D:\Downloaded Indeed Resume - Store")
oStream.Close
Next j
Set objIE = Nothing
End Sub
Related
Very new to VBA, and am really stuck. Below is my code, you'll see near the end my For loop for Des and DesArr. All I'm trying to do with that loop is pull a column of cells from the work sheet "SIC", which is Sheet2 in my Workbook, I either get the error "Subscript out of Range" or "Type Mismatch" and whenever I try and google/correct for one, the other error takes its place. If anyone can help me work through this I'd greatly appreciate it!
Public Sub getGoogleDescriptions(strSearch As String)
Dim URL As String, strResponse As String
Dim objHTTP As Object
Dim htmlDoc As HTMLDocument
Dim result As String
Dim i As Integer
Dim u As Integer
Dim resultArr As Variant
Dim Des As String
Dim DesArr(2 To 48) As Long
Set htmlDoc = CreateObject("htmlfile")
'Set htmlDoc = New HTMLDocument
Dim objResults As Object
Dim objResult As Object
strSearch = Replace(strSearch, " ", "+")
URL = "https://www.google.com/search?q=" & strSearch
Set objHTTP = CreateObject("MSXML2.XMLHTTP")
With objHTTP
.Open "GET", URL, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send
htmlDoc.body.innerHTML = .responseText
End With
Set objResults = htmlDoc.getElementsByClassName("st")
Debug.Print objResults(0).innerText
result = CStr(objResults(0).innerText)
resultArr = Split(result, " ", -1, 0)
For i = LBound(resultArr) To UBound(resultArr) 'Define i to be the length of the List'
Debug.Print i, resultArr(i) 'Prints the corresponding index value and array element'
Next i 'repeat
Set htmlDoc = Nothing
Set objResults = Nothing
Set objHTTP = Nothing
Set wk = ActiveWorkbook
For u = 2 To 48
Des = Sheets("SIC").Range("C" & u).Value
DesArr(u) = Des
Next u
Debug.Print DesArr(2)
End Sub
You're getting type mismatch because it's expecting DesArr to be a long data type which is a number between -2,147,483,648 to 2,147,483,647.
In it's use within the subroutine, it's used as a variant. So 2 corrections - change it to a variant as shown below
Then just adjust your 2 to 48 to within your statement... in this case it's a simple offset of 2, so just use (u - 2) and your Variant length is 47 starting at 0 instead of 1.
Public Sub getGoogleDescriptions(strSearch As String)
Dim URL As String, strResponse As String
Dim objHTTP As Object
Dim htmlDoc As HTMLDocument
Dim result As String
Dim i As Integer
Dim u As Integer
Dim resultArr As Variant
Dim Des As String
Dim DesArr(0) : ReDim DesArr(46)
Set htmlDoc = CreateObject("htmlfile")
'Set htmlDoc = New HTMLDocument
Dim objResults As Object
Dim objResult As Object
strSearch = Replace(strSearch, " ", "+")
URL = "https://www.google.com/search?q=" & strSearch
Set objHTTP = CreateObject("MSXML2.XMLHTTP")
With objHTTP
.Open "GET", URL, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send
htmlDoc.body.innerHTML = .responseText
End With
Set objResults = htmlDoc.getElementsByClassName("st")
Debug.Print objResults(0).innerText
result = CStr(objResults(0).innerText)
resultArr = Split(result, " ", -1, 0)
For i = LBound(resultArr) To UBound(resultArr) 'Define i to be the length of the List'
Debug.Print i, resultArr(i) 'Prints the corresponding index value and array element'
Next i 'repeat
Set htmlDoc = Nothing
Set objResults = Nothing
Set objHTTP = Nothing
Set wk = ActiveWorkbook
For u = 2 To 48
Des = Sheets("SIC").Range("C" & u).Value
DesArr(u - 2) = Des
Next u
Debug.Print DesArr(0)
End Sub
I am using the code below to download PDF files from a website and then I want to save them in local drive.
I am trying to save files using oStream.SaveToFile method but files are being downloaded in corrupted format error. Or when I'm using oStream.Save method, files are not being downloaded at all. Please help.
Sub login()
Dim objIE As InternetExplorer
Dim uid As String
Dim pwd As String
Dim rng As Range
Dim sh As Worksheet
Dim objCollection As Object
Dim buttonCollection As Object
Dim ieElement As Object
Dim ieButton As Object
Dim WinHttpReq As Object
Dim oStream As Object
Dim MyURL As String
Application.ScreenUpdating = False
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
Set sh = Sheets("Indeed Resume Download")
Set rng = sh.Range("A2")
If Trim(rng.Value) = "" Or Trim(rng.Offset(0, 1).Value) = "" Then
MsgBox "User ID And Password are mandatory."
Exit Sub
End If
On Error Resume Next
objIE.Quit
Set objIE = Nothing
On Error GoTo 0
uid = rng.Value
pwd = rng.Offset(0, 1).Value
Dim j As Long
Set objIE = New InternetExplorer 'Initialize internet object
objIE.Navigate "https://secure.indeed.com/account/login?service=my&hl=en_IN&co=IN&continue=https%3A%2F%2Fwww.indeed.co.in%2F"
objIE.Visible = True
With objIE
Do While .Busy: Loop
Do While .ReadyState <> READYSTATE_COMPLETE: Loop
Do While .Busy: Loop
End With
objIE.Document.all.signin_email.Value = uid
objIE.Document.all.signin_password.Value = pwd
Set ieElement = objIE.Document.getElementsByClassName("sg-btn sg-btn-primary btn-signin")(0)
ieElement.Click
For j = 2 To sh.Cells(Rows.Count, 27).End(xlUp).Row
Set objIE = New InternetExplorer
objIE.Visible = True
Dim Sender As String
MyURL = sh.Range("XDA" & j).Value
Sender = sh.Range("XDB" & j).Value
objIE.Navigate MyURL
Do While objIE.Busy = True
DoEvents
Loop
Do While objIE.Busy: Loop
Do While objIE.ReadyState <> READYSTATE_COMPLETE: Loop
Do While objIE.Busy: Loop
On Error Resume Next
Set ieButton = objIE.Document.getElementsByClassName("button download_button")(0)
ieButton.Click
WinHttpReq.Open "GET", MyURL, False
WinHttpReq.Send
MyURL = WinHttpReq.responseBody
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.Save ("D:\Downloaded Indeed Resume - Store")
'oStream.SaveToFile ("D:\Downloaded Indeed Resume - Store\" & Sender & ".pdf"), adSaveCreateOverWrite
oStream.Close
Next j
Set objIE = Nothing
End Sub
On line:
Set ieElement = objIE.Document.getElementsByClassName("sg-btn sg-btn-primary btn-signin")
ieElement.Click of the below code throws an error called "Object does not support this property or method".
Sub login()
Dim objIE As InternetExplorer
Dim uid As String
Dim pwd As String
Dim rng As Range
Dim sh As Worksheet
Dim ieElement As Object
Set sh = Sheets("Indeed Resume Download")
Set rng = sh.Range("A2")
On Error Resume Next
objIE.Quit
Set objIE = Nothing
On Error GoTo 0
uid = rng.Value
pwd = rng.Offset(0, 1).Value
Dim j As Long
Set objIE = New InternetExplorer 'Initialize internet object
objIE.Navigate "https://secure.indeed.com/account/loginservice=my&hl=en_IN&co=IN&continue=https%3A%2F%2Fwww.indeed.co.in%2F"
objIE.Visible = True
objIE.Document.all.signin_email.Value = UserID
objIE.Document.all.signin_password.Value = Password
Set ieElement = objIE.Document.getElementsByClassName("sg-btn sg-btn-primary btn-signin")
ieElement.Click
For j = 2 To sh.Cells(Rows.Count, 27).End(xlUp).Row
Set objIE = New InternetExplorer
With objIE
.Navigate sh.Range("CA" & j).Value
Do While .Busy = True
DoEvents
Loop
Do While .Busy: Loop
Do While .ReadyState <> READYSTATE_COMPLETE: Loop
Do While .Busy: Loop
End With
Do While objIE.Busy = True
DoEvents
Loop
Next j
Set objIE = Nothing
End Sub
When you use getElementsByClassName, you have to determine which class name you are wanting, as there can be many. If your class name is unique (which in this case it appears it could be), you can simply add a (0) to the end. If you want to search through all the class names you could use a For Each...Next statement.
Notice the different between these:
getElementByID() and getElementsByClassName()? Elements is plural when used with ClassName, so you need to designate which element of that class you want.
Try replacing your line with this:
Set ieElement = objIE.Document.getElementsByClassName("sg-btn sg-btn-primary btn-signin")(0)
The method you are currently using would work along these lines:
Dim ieElements, ieElemBtn, ieElement
Set ieElements = objIE.Document.getElementsByClassName("sg-btn sg-btn-primary btn-signin")
For Each ieElement in ieElements
If ieElement ..... Then
Set ieElemBtn = ieElement
Exit For
End If
Next ieElement
ieElemBtn.Click
The program works (needed text displayed in Excel). But after that IE stops working and Run-time error 462 (The remote server machine does not exist or is unavailable) . Searching solution in the internet. https://support.microsoft.com/en-us/kb/178510 .
I can not effectively change the code .
Sub extractTablesData1()
Dim IE As Object
Dim Data As Object
Dim xlApp As Excel.Application
Dim xlwb As Excel.Workbook
Dim xlsh As Excel.Worksheet
Dim i As Integer
Dim elemCollection As Variant
Set xlApp = CreateObject("Excel.Application")
Set xlwb = xlApp.Workbooks("IESite.xlsx")
Set xlsh = xlwb.Worksheets("Data")
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Visible = False
.navigate ("http://allscores.ru/soccer/new_ftour.php?champ=2404&f_team=406&tour=110")
While IE.ReadyState <> 4
DoEvents
Wend
Set Data = IE.document.getElementsbyTagName("table")(6).querySelectorAll("td.clr, td.clr_win, td.clr_draw, td.clr_loose")
i = 1
For Each elemCollection In Data
xlsh.Cells(34, 1 + i).Value = elemCollection.innerText
i = i + 1
Next elemCollection
End With
IE.Quit
Set IE = Nothing
End Sub
As described in the link:
RESOLUTION
To resolve this problem, modify the code so each call to an Excel object, method, or property is qualified with the appropriate object variable.
You are using:
ActiveWorkbook.Sheets(1).Cells(34, 1 + i).Value
This should be:
Dim xlwb as Workbook
Dim xlsh as Worksheet
set xlwb = Workbooks("IESite")
set xlsh = xlwb.Worksheets("Data")
xlsh.Cells(34, 1 + i).Value = elemCollection.innerText
Further changes:
As required by the solution, everything needs to be defined. Let me know if with the below way it does work, if so i'll remove the code above.
Don't forget to define ElemCollection
Sub extractTablesData1()
Dim IE As Object
Dim Data As Object
Dim xlApp As Excel.Application
Dim xlwb As Excel.Workbook
Dim xlsh As Excel.Worksheet
Dim i As Integer
Dim elemCollection as ... 'please define elemCollection as the type it is
Set xlApp = CreateObject("Excel.Application")
Set xlwb = xlApp.Workbooks("IESite.xlsx")
Set xlsh = xlwb.Worksheets("Data")
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Visible = False
.navigate ("http://allscores.ru/soccer/new_ftour.php?champ=2404&f_team=406&tour=110")
While IE.ReadyState <> 4
DoEvents
Wend
Set Data = IE.document.getElementsbyTagName("table")(6).querySelectorAll("td.clr, td.clr_win, td.clr_draw, td.clr_loose")
i = 1
For Each elemCollection In Data
xlsh.Cells(34, 1 + i).Value = elemCollection.innerText
i = i + 1
Next elemCollection
End With
IE.Quit
Set IE = Nothing
End Sub
All,
I've created the following Module to scrape a single value (1m % change in London house prices) from the below address:
https://www.hometrack.com/uk/insight/uk-cities-house-price-index/
The specific value is nested within the following code:
The below VBA code is my attempt at scraping. I, perhaps wrongly, feel that I am very close to capturing the value - but the code will not work.
Does anyone know where I am going wrong here? It doesn't show an error message but also doesn't output any values.
Sub HousePriceData()
Dim wb As Workbook
Dim ws As Worksheet
Dim TxtRng As Range
Dim ie As Object
Dim V As Variant
Dim myValue As Variant
Set ie = CreateObject("INTERNETEXPLORER.APPLICATION")
ie.NAVIGATE "https://www.hometrack.com/uk/insight/uk-cities-house-price-index/"
ie.Visible = False
While ie.ReadyState <> 4
DoEvents
Wend
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Input")
Set TxtRng = ws.Range("C15")
Set myValue = ie.document.getElementById("cities-index-table").getElementsByTagName("tr")(7).getElementsByTagName("td")(5)
TxtRng = myValue.innerText
End Sub
Try to use XHR and primitive parsing instead of awkward IE:
Sub Test()
Dim strUrl As String
Dim strTmp As String
Dim arrTmp As Variant
strUrl = "https://www.hometrack.com/uk/insight/uk-cities-house-price-index/"
With CreateObject("MSXML2.XMLHttp")
.Open "GET", strUrl, False
.Send ""
strTmp = .ResponseText
End With
arrTmp = Split(strTmp, ">London</a></td>", 2)
strTmp = arrTmp(1)
arrTmp = Split(strTmp, "<td>", 7)
strTmp = arrTmp(6)
arrTmp = Split(strTmp, "</td>", 2)
strTmp = arrTmp(0)
ThisWorkbook.Sheets("Input").Range("C15").Value = strTmp
End Sub
try use this
Dim Engmt As String
Engmt = "ERRORHERE"
On Error Resume Next
Engmt = Trim(ie.document.getElementById("cities-index- table").getElementsByTagName("tr")(12).getElementsByTagName("td")(4).innerText)
On Error GoTo 0
If Engmt = "ERRORHERE" Then
TxtRng.Value = "ERROR"
Else
TxtRng.Value = Engmt
End If