Run-Time Error 5

S

sflash11

New Member
Joined
Jun 20, 2017
Messages
3
I inherited this piece of code for VBA, every time I try to run the program I end up getting a run time error 5. Previously I thought I had it debugged after putting in a pause, but that only worked for so long. I am working in excel 2013. The code is as follows:

Sub FAANotice()
Dim strTable As String
Dim Datum, strDatum, strStr, strLat, strLong, strElev, strHgt, strTraverseway, strOnAirport As String
Dim dpos, mpos, spos, dpos1, mpos1, spos1 As String
Dim latDir, latD, latM, latS As String
Dim longDir, longD, longM, longS As String
Dim TW As String
Dim imgURL, webpage, strResult As String
Dim strDesktop, strLocalPath, strPath As String
Dim arrWebpage() As String
Dim r, x, y, SavePDF, SaveImg, c As Integer
Dim fldr As FileDialog
Dim LastRow As Long
Dim Prt
Dim CurrentDefaultPrinter, DefaultPrinter As String

With Worksheets("StrList")
strTable = .Cells.Find(What:="Structure Number", After:=ActiveCell, LookIn:= _
xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Address

c = Range(strTable).Column
r = Range(strTable).Row

LastRow = .Cells(.Rows.Count, c).End(xlUp).Row
End With

Datum = ""
Do Until Datum <> ""
strDatum = InputBox("Type '1' for NAD83 and '2' for NAD27")
Select Case strDatum
Case 1
Datum = "NAD83"
Case 2
Datum = "NAD27"
Case Else
MsgBox "Incorrect 'Datum' selected. Please select NAD83 or NAD27."
Datum = ""
End Select
Loop

'SavePDF = MsgBox("Do you want to save the Results from the FAA website for" & vbCrLf & "each structure?" & vbCrLf & vbCrLf & "NOTE: A SAVE PDF WINDOW WILL OPEN FOR EACH STRUCTURE.", vbYesNo + vbQuestion, "Save PDF Reports")
If SavePDF = vbYes Then
CurrentDefaultPrinter = Application.ActivePrinter
CurrentDefaultPrinter = Left(CurrentDefaultPrinter, InStr(CurrentDefaultPrinter, " on ") - 1)
'MsgBox CurrentDefaultPrinter


Prt = Application.Dialogs(xlDialogPrinterSetup).Show
If Prt = False Then Exit Sub
DefaultPrinter = Application.ActivePrinter
DefaultPrinter = Left(DefaultPrinter, InStr(DefaultPrinter, " on ") - 1)
'MsgBox DefaultPrinter

SetDefaultPrinter (DefaultPrinter)
End If

SaveImg = MsgBox("Do you want to save the map" & vbCrLf & "images from the FAA website" & vbCrLf & "for each structure?", vbYesNo + vbQuestion, "Save Map Images")
If SaveImg = vbYes Then
strDesktop = CreateObject("WScript.Shell").SpecialFolders("Desktop")
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder to Save Map Images..."
.AllowMultiSelect = False
.InitialFileName = strDesktop
If .Show <> True Then Exit Sub
strLocalPath = .SelectedItems(1)
End With
End If

r = r + 1
Do Until r = LastRow + 1

strStr = Worksheets("StrList").Range("B" & r).Value
strLat = Worksheets("StrList").Range("I" & r).Value
strLong = Worksheets("StrList").Range("H" & r).Value
strElev = Round(Worksheets("StrList").Range("F" & r).Value, 0)
strHgt = Round(Worksheets("StrList").Range("G" & r).Value, 0)
strTraverseway = Worksheets("StrList").Range("J" & r).Value
strOnAirport = Worksheets("StrList").Range("K" & r).Value

'124d15'49.676"W

dpos = InStr(strLat, "d")
mpos = InStr(strLat, "'")
spos = InStr(strLat, Chr(34))
latDir = Right(strLat, 1)
latD = Left(strLat, dpos - 1)
latM = Mid(strLat, dpos + 1, mpos - dpos - 1)
latS = Round(Val(Mid(strLat, mpos + 1, spos - dpos - 1)), 2)

dpos1 = InStr(strLong, "d")
mpos1 = InStr(strLong, "'")
spos1 = InStr(strLong, Chr(34))
longDir = Right(strLong, 1)
longD = Left(strLong, dpos1 - 1)
longM = Mid(strLong, dpos1 + 1, mpos1 - dpos1 - 1)
longS = Round(Val(Mid(strLong, mpos1 + 1, spos1 - mpos1 - 1)), 2)

With CreateObject("InternetExplorer.Application")
.Navigate "https://oeaaa.faa.gov/oeaaa/external/gisTools/gisAction.jsp?action=showNoNoticeRequiredToolForm"
.Visible = True
Do While .busy: DoEvents: Loop
Do While .ReadyState <> 4: DoEvents: Loop

'Latitude
.Document.Forms("dataForm").elements("latD").Value = latD 'Len=2
.Document.Forms("dataForm").elements("latM").Value = latM 'Len=2
.Document.Forms("dataForm").elements("latS").Value = latS 'Len=5
.Document.Forms("dataForm").elements("latDir").Value = latDir 'N/S

'Longitude
.Document.Forms("dataForm").elements("longD").Value = longD 'Len=3
.Document.Forms("dataForm").elements("longM").Value = longM 'Len=2
.Document.Forms("dataForm").elements("longS").Value = longS 'Len=5
.Document.Forms("dataForm").elements("longDir").Value = longDir 'W/E

'Horizontal Datum
.Document.Forms("dataForm").elements("datum").Value = Datum 'NAD83/NAD27

'Site Elevation
.Document.Forms("dataForm").elements("siteElevation").Value = strElev 'Len=5 Nearest Foot

'Structure Height(AGL)
.Document.Forms("dataForm").elements("unadjustedAgl").Value = strHgt 'Len=4 Nearest Foot

'Traverseway
'NO=No Traverseway, IH=Interstate Highway, PR=Private Road, PH=Public Roadway, RR=Railroad, WW=Waterway
Select Case strTraverseway
Case "No Traverseway"
TW = "NO"
Case "Interstate Highway"
TW = "IH"
Case "Private Road"
TW = "PR"
Case "Public Roadway"
TW = "PH"
Case "Railroad"
TW = "RR"
Case "Waterway"
TW = "WW"
Case Else
MsgBox "Missing 'Traverseway' information. Correct and re-run."
Exit Sub
End Select
.Document.Forms("dataForm").elements("traverseway").Value = TW


'Is structure on airport
Select Case strOnAirport
Case "Yes"
.Document.all("onAirport")(1).Checked = True 'true/false
Case "No"
.Document.all("onAirport")(0).Checked = True 'true/false
Case Else
MsgBox "Missing 'On Airport?' information. Correct and re-run."
Exit Sub
End Select

.Document.all("submit").Click
Application.Wait (Now + TimeValue("00:00:01"))
.Document.all("submit").Click


Do While CBool(InStrB(1, .Document.URL, _
"action=showNoNoticeRequiredToolForm"))
DoEvents
Loop
Do While .busy: DoEvents: Loop
Do While .ReadyState <> 4: DoEvents: Loop


If SaveImg = vbYes Then
imgURL = .Document.images("map").src
strPath = strLocalPath & "" & strStr & ".png"

Ret = URLDownloadToFile(0, imgURL, strPath, 0, 0)

If Ret <> 0 Then
MsgBox "Unable to download the file"
End If
End If

webpage = .Document.body.innerText
webpage = Replace(webpage, Chr(10), Chr(13))
arrWebpage = Split(webpage, Chr(13))

x = 0
strResult = ""
For y = LBound(arrWebpage) To UBound(arrWebpage)
If arrWebpage(y) <> "" Then
If x > 0 Then
If InStr(arrWebpage(y), "FAA.gov") <> 0 Then
x = 0
Else
strResult = strResult & arrWebpage(y) & Chr(10)
End If
End If

If InStr(arrWebpage(y), "Results") <> 0 Then
x = x + 1
End If
End If
Next

Worksheets("StrList").Range("L" & r) = strResult
strResult = Left(strResult, Len(strResult) - 3)


If SavePDF = vbYes Then
.ExecWB OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER
End If

.Quit
End With
Worksheets("StrList").Range("N" & r).Value = Now

r = r + 1
Loop

'SetDefaultPrinter (CurrentDefaultPrinter)
MsgBox "Done!"


End Sub



The error is in red. If anyone can help that would be greatly appreciated.
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
Sort by date Sort by votes
Here is what I have so far in terms of updated code
Code: 
Sub FAANotice()
    Dim strTable As String
    Dim Datum As String, strDatum As String, strStr As String, strLat As String, strLong As String, strElev As String, strHgt As String, strTraverseway As String, strOnAirport As String
    Dim dpos As String, mpos As String, spos As String, dpos1 As String, mpos1 As String, spos1 As String
    Dim latDir As String, latD As String, latM As String, latS As String
    Dim longDir As String, longD As String, longM As String, longS As String
    Dim TW As String
    Dim imgURL As String, webpage As String, strResult As String
    Dim strDesktop As String, strLocalPath As String, strPath As String
    Dim arrWebpage() As String
    Dim r As Long, x As Long, y As Long, SavePDF, SaveImg, c As Long
    'dim variables as long instead of integers (above)
    Dim fldr As FileDialog
    Dim LastRow As Long
    Dim Prt
    Dim CurrentDefaultPrinter As String, DefaultPrinter As String
    
    With Worksheets("StrList")
        strTable = .Cells.Find(What:="Structure Number", After:=ActiveCell, LookIn:= _
                    xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
                    xlNext, MatchCase:=False, SearchFormat:=False).Address
        
        c = Range(strTable).Column
        r = Range(strTable).Row
        
        LastRow = .Cells(.Rows.Count, c).End(xlUp).Row
    End With
    
    Datum = ""
    Do Until Datum <> ""
        strDatum = InputBox("Type '1' for NAD83 and '2' for NAD27")
        Select Case strDatum
            Case 1
                Datum = "NAD83"
            Case 2
                Datum = "NAD27"
            Case Else
                MsgBox "Incorrect 'Datum' selected. Please select NAD83 or NAD27."
                Datum = ""
        End Select
    Loop
    
    'SavePDF = MsgBox("Do you want to save the Results from the FAA website for" & vbCrLf & "each structure?" & vbCrLf & vbCrLf & "NOTE: A SAVE PDF WINDOW WILL OPEN FOR EACH STRUCTURE.", vbYesNo + vbQuestion, "Save PDF Reports")
    If SavePDF = vbYes Then
        CurrentDefaultPrinter = Application.ActivePrinter
        CurrentDefaultPrinter = Left(CurrentDefaultPrinter, InStr(CurrentDefaultPrinter, " on ") - 1)
        'MsgBox CurrentDefaultPrinter


        Prt = Application.Dialogs(xlDialogPrinterSetup).Show
        If Prt = False Then Exit Sub
        DefaultPrinter = Application.ActivePrinter
        DefaultPrinter = Left(DefaultPrinter, InStr(DefaultPrinter, " on ") - 1)
        'MsgBox DefaultPrinter
        
        SetDefaultPrinter (DefaultPrinter)
    End If
    
    SaveImg = MsgBox("Do you want to save the map" & vbCrLf & "images from the FAA website" & vbCrLf & "for each structure?", vbYesNo + vbQuestion, "Save Map Images")
    If SaveImg = vbYes Then
        strDesktop = CreateObject("WScript.Shell").SpecialFolders("Desktop")
        Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
        With fldr
            .Title = "Select a Folder to Save Map Images..."
            .AllowMultiSelect = False
            .InitialFileName = strDesktop
            If .Show <> True Then Exit Sub
            strLocalPath = .SelectedItems(1)
        End With
    End If
    
    r = r + 1
    Do Until r = LastRow + 1
    
        strStr = Worksheets("StrList").Range("B" & r).Value
        strLat = Worksheets("StrList").Range("I" & r).Value
        strLong = Worksheets("StrList").Range("H" & r).Value
        strElev = Round(Worksheets("StrList").Range("F" & r).Value, 0)
        strHgt = Round(Worksheets("StrList").Range("G" & r).Value, 0)
        strTraverseway = Worksheets("StrList").Range("J" & r).Value
        strOnAirport = Worksheets("StrList").Range("K" & r).Value
        
        '124d15'49.676"W
        
        dpos = InStr(strLat, "d")
        mpos = InStr(strLat, "'")
        spos = InStr(strLat, Chr(34))
        latDir = Right(strLat, 1)
        latD = Left(strLat, dpos - 1)
        latM = Mid(strLat, dpos + 1, mpos - dpos - 1)
        latS = Round(Val(Mid(strLat, mpos + 1, spos - dpos - 1)), 2)
    
        dpos1 = InStr(strLong, "d")
        mpos1 = InStr(strLong, "'")
        spos1 = InStr(strLong, Chr(34))
        longDir = Right(strLong, 1)
        longD = Left(strLong, dpos1 - 1)
        longM = Mid(strLong, dpos1 + 1, mpos1 - dpos1 - 1)
        longS = Round(Val(Mid(strLong, mpos1 + 1, spos1 - mpos1 - 1)), 2)
          
        With CreateObject("InternetExplorer.Application")
            .Navigate "https://oeaaa.faa.gov/oeaaa/external/gisTools/gisAction.jsp?action=showNoNoticeRequiredToolForm"
            .Visible = True
            Do While .busy: DoEvents: Loop
            Do While .ReadyState <> 4: DoEvents: Loop
            
            'Latitude
            .Document.Forms("dataForm").elements("latD").Value = latD 'Len=2
            .Document.Forms("dataForm").elements("latM").Value = latM 'Len=2
            .Document.Forms("dataForm").elements("latS").Value = latS 'Len=5
            .Document.Forms("dataForm").elements("latDir").Value = latDir 'N/S
            
            'Longitude
            .Document.Forms("dataForm").elements("longD").Value = longD  'Len=3
            .Document.Forms("dataForm").elements("longM").Value = longM 'Len=2
            .Document.Forms("dataForm").elements("longS").Value = longS 'Len=5
            .Document.Forms("dataForm").elements("longDir").Value = longDir 'W/E
            
            'Horizontal Datum
            .Document.Forms("dataForm").elements("datum").Value = Datum 'NAD83/NAD27
            
            'Site Elevation
            .Document.Forms("dataForm").elements("siteElevation").Value = strElev 'Len=5 Nearest Foot
            
            'Structure Height(AGL)
            .Document.Forms("dataForm").elements("unadjustedAgl").Value = strHgt 'Len=4 Nearest Foot
            
            'Traverseway
            'NO=No Traverseway, IH=Interstate Highway, PR=Private Road, PH=Public Roadway, RR=Railroad, WW=Waterway
            Select Case strTraverseway
                Case "No Traverseway"
                    TW = "NO"
                Case "Interstate Highway"
                    TW = "IH"
                Case "Private Road"
                    TW = "PR"
                Case "Public Roadway"
                    TW = "PH"
                Case "Railroad"
                    TW = "RR"
                Case "Waterway"
                    TW = "WW"
                Case Else
                    MsgBox "Missing 'Traverseway' information. Correct and re-run."
                    Exit Sub
            End Select
            .Document.Forms("dataForm").elements("traverseway").Value = TW
            
        
            'Is structure on airport
            Select Case strOnAirport
                Case "Yes"
                    .Document.all("onAirport")(1).Checked = True  'true/false
                Case "No"
                    .Document.all("onAirport")(0).Checked = True  'true/false
                Case Else
                    MsgBox "Missing 'On Airport?' information. Correct and re-run."
                    Exit Sub
            End Select
        
            .Document.all("submit").Click
                Application.Wait (Now + TimeValue("00:00:01"))
            .Document.all("submit").Click
        
        
            Do While CBool(InStrB(1, .Document.URL, _
                "action=showNoNoticeRequiredToolForm"))
                DoEvents
            Loop
            Do While .busy: DoEvents: Loop
            Do While .ReadyState <> 4: DoEvents: Loop


            If SaveImg = vbYes Then
                imgURL = .Document.images("map").src
                strPath = strLocalPath & "\" & strStr & ".png"
                
                Ret = URLDownloadToFile(0, imgURL, strPath, 0, 0)
    
                If Ret <> 0 Then
                    MsgBox "Unable to download the file"
                End If
            End If
            
            webpage = .Document.body.innerText
            webpage = Replace(webpage, Chr(10), Chr(13))
            arrWebpage = Split(webpage, Chr(13))
            
            x = 0
            strResult = ""
            For y = LBound(arrWebpage) To UBound(arrWebpage)
                If arrWebpage(y) <> "" Then
                    If x > 0 Then
                        If InStr(arrWebpage(y), "FAA.gov") <> 0 Then
                            x = 0
                        Else
                            strResult = strResult & arrWebpage(y) & Chr(10)
                        End If
                    End If
                    
                    If InStr(arrWebpage(y), "Results") <> 0 Then
                        x = x + 1
                    End If
                End If
             Next
        
            Worksheets("StrList").Range("L" & r) = strResult
'            strResult = Left(strResult, Len(strResult) - 3)
           
            
            If SavePDF = vbYes Then
                .ExecWB OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER
            End If
            
            .Quit
        End With
        Worksheets("StrList").Range("N" & r).Value = Now
        
        r = r + 1
    Loop
    
    'SetDefaultPrinter (CurrentDefaultPrinter)
    MsgBox "Done!"


End Sub


I still have issues with getting blank boxes in my results column, picture included. As well as trying to find a way to make the macro run quicker and more efficiently.
 
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,223,889
Messages
6,175,223
Members
452,620
Latest member
dsubash

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top