Excel VBA Error - Runtime Error 70: Permission Denied - vba

I need help with a code that was written for me. The code is below. I works find perhaps 70% of the time, but every approx 20 rows it throws up
Runtime Error 70: Permission Denied
What would cause this, and is there any fix for it? Also, How can I change the code to skip any errors like this (or similar) and just move onto the next row.
Debugger throws up the line: If btn.ID = "gs_hdr_tsb" Then
The full script is below.
Dim ie As Object
Private Sub CommandButton1_Click()
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
ie.Navigate TextBox1.Text
Do
DoEvents
Loop Until ie.readystate = 4
Application.Wait (Now + TimeValue("00:00:02"))
End Sub
Private Sub CommandButton2_Click()
Dim i As Long
Dim prfl As String
Dim ws As Worksheet
Set ws = ActiveSheet
Dim INPTTG, btn As Object
Dim Profile_link As String
Dim H3tg As Object
Dim iedata As Object
If iedata Is Nothing Then
Set iedata = CreateObject("InternetExplorer.Application")
End If
iedata.Visible = True
For i = TextBox2.Text To TextBox3.Text
prfl = ws.Range("E" & i).Value
For Each INPTTG In ie.document.getelementsbytagname("input")
If INPTTG.classname = "gs_in_txt" Then
INPTTG.Value = ""
INPTTG.Value = prfl
Exit For
End If
Next INPTTG
'button
Application.Wait (Now + TimeValue("00:00:02"))
For Each btn In ie.document.getelementsbytagname("button")
If btn.ID = "gs_hdr_tsb" Then
btn.Click
Do
DoEvents
Loop Until ie.readystate = 4
Application.Wait (Now + TimeValue("00:00:02"))
End If
Next btn
'prfl
For Each H3tg In ie.document.getelementsbytagname("h3")
If H3tg.classname = "gsc_oai_name" And VBA.Trim(H3tg.innertext) = prfl Then
Call GetData(H3tg.getelementsbytagname("a").Item(0).href, iedata, i)
Exit For
End If
Next H3tg
TextBox2.Text = i
Next i
MsgBox "Completed"
iedata.Quit
Set iedata = Nothing
Application.DisplayAlerts = False
ThisWorkbook.Save
End Sub
Any help would be very appreciated.

Try this one.
Dim ie As Object
Private Sub CommandButton1_Click()
On error go to ErrMsg
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
ie.Navigate TextBox1.Text
Do
DoEvents
Loop Until ie.readystate = 4
Application.Wait (Now + TimeValue("00:00:02"))
ErrMsg:
End Sub
Private Sub CommandButton2_Click()
Dim i As Long
Dim prfl As String
Dim ws As Worksheet
Set ws = ActiveSheet
Dim INPTTG, btn As Object
Dim Profile_link As String
Dim H3tg As Object
Dim iedata As Object
On error go to msgErr
If iedata Is Nothing Then
Set iedata = CreateObject("InternetExplorer.Application")
End If
iedata.Visible = True
For i = TextBox2.Text To TextBox3.Text
prfl = ws.Range("E" & i).Value
For Each INPTTG In ie.document.getelementsbytagname("input")
If INPTTG.classname = "gs_in_txt" Then
INPTTG.Value = ""
INPTTG.Value = prfl
Exit For
End If
Next INPTTG
'button
Application.Wait (Now + TimeValue("00:00:02"))
For Each btn In ie.document.getelementsbytagname("button")
If btn.ID = "gs_hdr_tsb" Then
btn.Click
Do
DoEvents
Loop Until ie.readystate = 4
Application.Wait (Now + TimeValue("00:00:02"))
End If
Next btn
'prfl
For Each H3tg In ie.document.getelementsbytagname("h3")
If H3tg.classname = "gsc_oai_name" And VBA.Trim(H3tg.innertext) = prfl Then
Call GetData(H3tg.getelementsbytagname("a").Item(0).href, iedata, i)
Exit For
End If
Next H3tg
TextBox2.Text = i
Next i
MsgBox "Completed"
iedata.Quit
Set iedata = Nothing
Application.DisplayAlerts = False
ThisWorkbook.Save
MsgErr:
End Sub

There are several answers here on StackOverflow about this VB Error. Each answer or situation is unique in reality - although each existing answer states a different potential root cause (file permissions, folder permissions, name reuse, ranges, etc).
I would recommend narrowing down the root-cause by double clicking on the side of the stating function/code in order to mark a breakpoinnt (looks like a red dot) (Alternatively, you can right click on the line of the code - Select the Toggle and then Breakpoint).
Next, run your code, and it will stop in your breakpoint. You can then Step-Into/Over/Out your code and essentially find the line of code that is responsible for throwing your error code. (Step Into is F8, Step over is Shift+F8 ((Go To the Debug top menu to see more options)))
Once you identified the responsible line of code - you can start looking further.
In my case scenario, I was using a protected variable name "Date" (look into variable names). Once I renamed it to something else, the problem was fixed.

One possible cause of this error (as was my case) is an antivirus/antimalware program blocking certain libraries. Try temporarily disabling all antivirus/antimalware programs and test your script again. In my case, Malwarebytes
In MalWare bytes, you can disable this setting by going to:
Security > Advanced Settings > Application Hardening [tab]
On the row called "Disable Loading of VBScript Libraries", un-check the checkbox under "MS Office".

Related

Pause script till website fully loaded - Excel VBA

I'm currently trying to create a sheet which will extract tracking information for parcels sent out. I've worked out the following code for the time being but encounter the following issues:
The code continues before the page fully loads, I suspect this may be because after the initial loading is complete, it runs a script and refreshes.
If mouse is not rolling over Internet Explorer, high probability of a human verification with images. I understand this may not be possible to avoid but is there any way I can pause the script while someone completes the verification?
Sub RoyalTrack()
Dim i As Long
Dim ie As Object
Dim t As String
Set ie = CreateObject("InternetExplorer.Application")
With ie
.Visible = True
.Navigate "https://www.royalmail.com/track-your-item#/tracking-results/SF511991733GB"
.Resizable = True
End With
While ie.ReadyState <> 4 Or ie.Busy: DoEvents: Wend
Dim full As Variant
Dim latest As Variant
full = ie.Document.getElementsByClassName("c-tracking-history")(0).innerText
latest = ie.Document.getElementsByClassName("tracking-history-item ng-scope")(0).innerText
MsgBox full
MsgBox latest
End Sub
Managed to figure it out. Added a 2 second wait after page loads to allow loading and an error handler to identify if the required property is available.
Sub RoyalTrack()
Dim i As Long
Dim ie As Object
Dim t As String
Dim trackingN As String
Dim count As Integer
count = 2
Do While Worksheets("Sheet1").Range("D" & count).Value <> ""
Set ie = CreateObject("InternetExplorer.Application")
trackingN = Worksheets("Sheet1").Range("D" & count).Value
With ie
.Visible = True
' Variable tracking SF-GB
.Navigate "https://www.royalmail.com/track-your-item#/tracking-results/" & trackingN
.resizable = True
End With
While ie.readyState <> 4 Or ie.Busy: DoEvents: Wend
Application.Wait (Now + TimeValue("0:00:02"))
Dim full As Variant
Dim latest As Variant
On Error Resume Next
latest = ie.document.getElementsByClassName("tracking-history-item ng-scope")(0).innerText
If Err Then
MsgBox "Prove your humanity if you can"
Err.Clear
End If
latest = ie.document.getElementsByClassName("tracking-history-item ng-scope")(0).innerText
Windows("Book1.xls").Activate
Sheets("Sheet1").Select
Range("E" & count).Value = latest
ie.Quit
Set ie = Nothing
count = count + 1
Loop
End Sub

Internet-Explorer won't get closed after my module ends

I have this macro that pulls out data from a website. I get the inputs from a user-from. It works with no error but IE won't close and sucks up all of the memory. Is something else needed rather than IE.Quit?
This is the sub. As you can see I close IE at the end.
Public Cancel As Boolean
Sub USGD()
Dim IE As Object
Dim iWsh As Worksheet
Dim link As String
Dim sDate As String
Dim eDate As String
Dim StationID As String
Cancel = False
With USGS
.StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
.Show
End With
If Cancel = True Then
Unload USGS
Exit Sub
End If
With ActiveWorkbook
Set iWsh = .Sheets.Add(After:=.Sheets(.Sheets.Count))
End With
iWsh.Activate
iWsh.Range("A1").Select 'I know this is not efficient but works fine
StationID = USGS.TextBox1.Text
'StationID = InputBox("Please enter the station ID")
'sDate = InputBox("Please enter START date in this format: 'yyyy-mm-dd'")
'eDate = InputBox("Please enter END date in this format: 'yyyy-mm-dd'")
sDate = Format(USGS.TextBox2.Text, "yyyy-mm-dd")
eDate = Format(USGS.TextBox3.Text, "yyyy-mm-dd")
link = "https://waterdata.usgs.gov/ & _
StationID & sDate & eDate
Unload USGS
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Visible = False
.Navigate link 'URL
Do Until .ReadyState = 4: DoEvents: Loop
.ExecWB 17, 0 '// SelectAll
.ExecWB 12, 2 '// Copy selection
End With
iWsh.PasteSpecial Format:="Text", link:=False, DisplayAsIcon:=False
Range("A1").Select
IE.Quit
Set IE = Nothing
Set iWsh = Nothing
End Sub
And this is the user-form: I didn't have this problem while using Input-Box so I am guessing, it has something to do with the user-form. This only happens when user closes the user-form.
Private Sub ToggleButton1_Click()
Me.Hide
Cancel = True
End Sub
Private Sub OK_Click()
Me.Hide
End Sub
Note: If the user cancel, it would not even open the IE and exits the sub right after.
But if user closes the form, it does open IE, and doesn't set the Cancel to be True which is the condition to exit the sub.
Update: Expert-Exchange covered the issue but never came up with an actual solution.
Update-2: Closing all instances of IE is not an option.
This is how user-form is set up now:
OK so I am unable to replicate the error, so there are two things you should try:
Reboot your computer and verify the error continues. If not, problem solved.
Recreate the UserForm & code in a new, blank workbook, and see if the error continues. If not, problem solved.
(Sometimes Workbooks, and/or UserForms become corrupted)
I also re-factored the code a little bit, which you might consider even if one of the above suggestions solves the problem. It just cleans it up a little bit and makes it more purposeful.
In a standard module, place the following code:
The USGD procedure displays the userform and unloads it. A separate procedure named GetData will do the work in IE and add the worksheet, etc. The GetData procedure is only executed if the user clicks on the "OK" button on the form. Therefore, the "X"/cancel button will allow the user to close the form.
Option Explicit
Sub USGD()
'Procedure displays the userform for the user
Dim USGSForm As New USGS
With USGSForm
.StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
.Show
End With
Unload USGSForm
End Sub
Sub GetData(StationID As String, sDate As String, eDate As String)
'This procedure queries the InternetExplorer for the values from UserForm
Dim iWsh As Worksheet
Dim link As String
Dim IE As Object
sDate = Format(sDate, "yyyy-mm-dd")
eDate = Format(eDate, "yyyy-mm-dd")
link = "https://waterdata.usgs.gov/nwis/dv?cb_00060=on&format=rdb&site_no=" & _
StationID & "&referred_module=sw&period=&begin_date=" & sDate & "&end_date=" & eDate
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Visible = False
.Navigate link 'URL
Do Until .ReadyState = 4: DoEvents: Loop
.ExecWB 17, 0 '// SelectAll
.ExecWB 12, 2 '// Copy selection
.Quit
End With
With ActiveWorkbook
Set iWsh = .Sheets.Add(After:=.Sheets(.Sheets.Count))
End With
iWsh.PasteSpecial Format:="Text", link:=False, DisplayAsIcon:=False
Application.GoTo iWsh.Range("A1")
End Sub
In your UserForm module, place the following code:
This is the code for the "OK" button, which takes the values from TextBoxes on the form and sends those to the GetData procedure. Note the Select Case logic which will exit the procedure early if any of the parameters are empty, so it will not call GetData.
Private Sub OK_Click()
Dim id As String, sDate As String, eDate As String
'Get values from the form
id = Me.TextBox1.Value
sDate = Me.TextBox2.Value
eDate = Me.TextBox3.Value
'Hide the form
Me.Hide
'If ANY required parameter is blank, this results in malformed URL so exit the procedure
Select Case vbNullString
Case id, sDate, eDate
MsgBox "You left some parameter blank, no query will be performed.", vbInformation
GoTo EarlyExit
Case Else
'Send values to the procedure that queries IE
Call GetData(id, sDate, eDate)
End Select
EarlyExit:
End Sub
I found a workaround but not a good answer. Also, does not explain why that happens.
I changed my user-form so the user cannot close it. Also set the initial value of Cancel to be True
Cancel = True
and when the use pushes OK it will be set to false. Look below for the user form code:
Private Sub ToggleButton1_Click()
End Sub
Private Sub OK_Click()
Me.Hide
Cancel = False
End Sub
Obvious downside of this is that users cannot close the user-form; they have to hit OK. This won't cause an error. I just can add a condition that if one of the text boxes was empty then exit the sub. Something like below;
If sDate = "" Or eDate = "" Or StationID = "" Then GoTo 92
'. Rest of ...
'. My ...
'. Code ...
92:
Set IE = Nothing
End Sub

Excel VBA multiple For loop not working

I seem to be stuck in an weird issue. I have the Excel VBA code below to visit a website and enter a userID (from the userID column A in sheet 1) and retrieve the name of the user which shows up after hitting the submit button then continues with the rest of the userIDs.
Public Sub TEST()
TestPage = "http://test.com/"
Dim IE As New InternetExplorer
Dim Doc As HTMLDocument
Dim GetElem As Object
Dim GetElem2 As Object
IE.Visible = True
IE.navigate TestPage
Do
DoEvents
Loop Until IE.readyState = READYSTATE_COMPLETE
Application.Wait (Now + TimeValue("0:00:04"))
Set Doc = IE.document
CurRow = Sheet1.UsedRange.Rows.Count
Do While CurRow > 0
Application.Wait (Now + TimeValue("0:00:4"))
'Find/Get the userID textbox and enter the current userID
For Each GetElem In Doc.getElementsByTagName("input")
If GetElem.ID = "query" Then 'I could just do getElementByID later
GetElem.Value = Sheet1.Range("A" & CurRow).Value
End If
Next
'Find and click the submit button
For Each GetElem2 In Doc.getElementsByTagName("button")
If GetElem2.Type = "submit" Then
GetElem2.Click
Application.Wait (Now + TimeValue("0:00:03"))
End If
Next
CurRow = CurRow - 1
Loop
End Sub
The problem is the code works only once. It enters the first userID into the text box and hits Submit. When it loops and tries to enter the next userID though, the code get stuck in a loop.
If I remove the entire 2nd For-Next loop it works (although it doesn't submit, it enters each of the userIDs in the text box).
On top of that, if I use the F8 debugging the code step by step, everything works fine. Only getting problems when fully running the code.:(
Public Sub TEST()
TestPage = "http://test.com/"
Dim IE As New InternetExplorer
Dim Doc As HTMLDocument
Dim GetElem As Object
Dim GetElem2 As Object
IE.Visible = True
IE.navigate TestPage
Do
DoEvents
Loop Until IE.readyState = READYSTATE_COMPLETE
Application.Wait (Now + TimeValue("0:00:04"))
Set Doc = IE.document
CurRow = Sheet1.UsedRange.Rows.Count
For Each GetElem In Doc.getElementsByTagName("input")
If GetElem.ID = "query" Then 'I could just do getElementByID later
GetElem.Value = Sheet1.Range("A" & CurRow).Value
For Each GetElem2 In Doc.getElementsByTagName("button")
If GetElem2.Type = "submit" Then
GetElem2.Click
Application.Wait (Now + TimeValue("0:00:03"))
End If
Next GetElem2
End If
CurRow = CurRow + 1
Next GetElem
End Sub

Webbrowser control in userform: how to wait for page to initialize

Task: using Excel VBA to navigate to a website, log in and go to an input page.
On that page, sequentially enter a series of values stored in a column in Sheet1.
What I've done so far:
I create a webbrowser control and navigate to the website and stop.
Then click on a button on Sheet1 with the macros that will do the inputting, stored in a module.
What's happening:
The control comes up nicely and navigates to the intended site. (this is the userform code)
Click on the button and it gets the userid and password from the spreadsheet, inputs them, clicks on the login button and all is well.
However, the next statement is:
Set inputfield = WebBrowser.objWebBrowser.Document.getElementById("ctl02_ctl03_ddlBus")
and inputfield comes up empty.
If I stop execution and step through it, it'll work.
I've tried Application.Wait; For x = 1 to 5000000; On Error Goto/Resume and keep trying, but nothings works.
I've also tried .NavigateComplete, .DocumentCompleted, as well as others, but I get errors saying member is not supported.
I am at my wits end - I'm just so close!! So far, I've spent more time on this that it will ever save, but now it's personal! Thanks for your help.
This is borrowed code from another site that initializes the control.
Private Sub UserForm_Initialize()
Dim a, c As Integer
With Me
.StartUpPosition = 0
.Top = 150
.Left = -700
End With
With Me.objWebBrowser
.Navigate2 "http://www.schoolbuscity.com/Mapnetweb_47/login.aspx"
.Visible = True
End With
End Sub
Private Sub GetSheets()
'this is my code
Dim inputfield As Object
Dim SendText As String
Dim NumberOfRoutes, r, errCount As Integer
errCount = 0
NumberOfRoutes = Range("NumberOfRoutes")
ReDim RouteNumbers(NumberOfRoutes) As String
For r = 1 To NumberOfRoutes
RouteNumbers(r) = Cells(r, 1).Value
Next r
' Sheets("Sheet1").Select
Range(Cells(5, 2), Cells(6, 2)).ClearContents ' this indicates success for the chosen cells
SendText = Range("userid").Value
Set inputfield = WebBrowser.objWebBrowser.Document.getElementById("Login1_UserName")
inputfield.Value = SendText
SendText = Range("password").Value
Set inputfield = WebBrowser.objWebBrowser.Document.getElementById("Login1_Password")
inputfield.Value = SendText
Set inputfield = WebBrowser.objWebBrowser.Document.getElementById("Login1_Login")
Application.Wait (Now + TimeValue("0:00:01"))
inputfield.Click
Application.Wait (Now + TimeValue("0:00:01")) ' I've tried waiting for up to 10 seconds
Set inputfield = Nothing
On Error GoTo TryAgain
For r = 5 To 6 'NumberOfRoutes ' just want to use 2 loops for testing
' this is where is fails, I believe, because the page is not initialized
' but if waiting is not the answer, then what is?
Set inputfield = WebBrowser.objWebBrowser.Document.getElementById("ctl02_ctl03_ddlBus")
inputfield.Value = RouteNumbers(r)
Set inputfield = WebBrowser.objWebBrowser.Document.getElementById("ctl02_ctl03_btnGo")
inputfield.Click
Application.Wait (Now + TimeValue("0:00:01"))
Cells(r, 2).Value = "Sent"
' WebBrowser.objWebBrowser.Document.Print
WebBrowser.objWebBrowser.GoBack
Next r
GoTo EndIt
TryAgain:
Set inputfield = Nothing
Set inputfield = WebBrowser.objWebBrowser.Document.getElementById("ctl02_ctl03_ddlBus")
errCount = errCount + 1
If errCount > 5 Then GoTo EndIt
Resume
EndIt:
If errCount > 0 Then
MsgBox "errCount= " + CStr(errCount)
Else
MsgBox "Did it"
End If
End Sub
This is how to waitbin vbscript.
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = 0
'must navigate to a local file to avoid security prompts
ie.Navigate2 "C:\Users\User\Desktop\Filter.html"
Do
wscript.sleep 100
Loop until ie.document.readystate = "complete"
examples in VBA:
Private Sub UserForm_Initialize()
Set ie = Me.WebBrowser1
ie.Navigate2 "about:blank"
Do Until ie.ReadyState = READYSTATE_COMPLETE
DoEvents
Loop
Set ie = Nothing
End Sub
Private Sub Conectar_Click()
Dim ie As Object
Set ie = Me.WebBrowser1
ie.Navigate2 "http://www.mytest.com"
Do Until ie.ReadyState = READYSTATE_COMPLETE
DoEvents
Loop
'different alternatives
'Dim inputfield As Object
'Set inputfield = ie.Document.getElementById("Login_tbLogin")
'inputfield.Value = "mylogin"
'Set inputfield = Nothing
'ie.Document.getElementById("Login_tbLogin").Value = "mylogin"
'ie.Document.All("Login_tbLogin").Focus
'ie.Document.All("Login_tbLogin").Value = "mylogin"
ie.Document.All.Item("Login_tbLogin").Value = "mylogin"
Set ie = Nothing
End Sub

VBA Error 70: Permission Denied during IE automation

I've been trying to create a quick subroutine in VBA through Excel 2010 to automate putting a list of URLs through bit.ly and copying the abbreviated links back to replace their original link. BUT I'm getting an Error 70: Permission Denied runtime error along the way. I've had a few courses and this MOSTLY works, but I'm not highly familiar with VBA and could use some help in debugging this if possible (it'd be a huge help). Here's the code:
Option Explicit
Dim IE As Object
Sub AutoAbbrev()
Set IE = CreateObject("InternetExplorer.Application")
Dim holdURL As String
Dim row_number As Integer
IE.Visible = True
For row_number = 101 To 112
holdURL = ""
If Range("b" & row_number).Value = "" Then GoTo Skip
IE.navigate "http://www.bitly.com" 'load bit.ly
Do While IE.readyState <> 4
DoEvents
Loop
IE.document.all("shorten_url").Value = Range("b" & row_number).Value
IE.document.all("shorten_btn").Click
Do While IE.document.all("shorten_url").Value = Range("b" & row_number).Value Or IE.document.all("shorten_url").Value = ""
DoEvents
Loop
holdURL = IE.document.all("shorten_url").Value
IE.document.all("shorten_url").Value = ""
Range("b" & row_number).Value = holdURL
Skip:
Next row_number
End Sub
Private Sub Command1_Click()
AutoAbbrev
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set IE = Nothing
If TypeName(IE) <> "Nothing" Then Unload IE
Set IE2 = Nothing
If TypeName(IE2) <> "Nothing" Then Unload IE2
End Sub
The error is mostly thrown on this line after the program has run through one or more iterations:
Do While IE.document.all("shorten_url").Value = Range("b" & row_number).Value Or IE.document.all("shorten_url").Value = ""
DoEvents
Loop
If any specific advice could be provided to help me over this hump, I'd greatly appreciate it. Thanks!
Automating Internet Explorer should always be a last resort, it's slow and relies on the structure of the page remaining unchanged. It's always better to opt for an API if one is available, in this case bitly provide an API for shotening links, you just need to get your Authentication Token and enter it in the below:
Public Function Shorten(url As String) As String
Const token As String = "YOUR AUTHENTICATION TOKEN"
Static oRequest As Object
If oRequest Is Nothing Then Set oRequest = CreateObject("winhttp.winhttprequest.5.1")
With oRequest
.Open "GET", "https://api-ssl.bitly.com/v3/shorten?access_token=" & token & "&longUrl=" & url & "&format=xml", False
.send
If Left(Split(.responsetext, "txt>")(1), 2) = "OK" Then Shorten = Split(Split(.responsetext, "url>")(1), "<")(0)
End With
End Function
You can then use the above as a function in your worksheet
I found this occurs because of the page not being fully loaded. IE is SLOW but sometimes you need to use it because you have dynamic content in Divs which need to be opened with an object.click event. Do Until Not appIE.Busy And appIE.ReadyState = 4: DoEvents: Loop can help but it can also hang up your browser so adding a wait period using a timer can help.