Run-Time Error 5

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.
 

sflash11

New Member
Joined
Jun 20, 2017
Messages
3
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.
 

Forum statistics

Threads
1,081,556
Messages
5,359,547
Members
400,533
Latest member
fpenning

Some videos you may like

This Week's Hot Topics

  • VBA (Userform)
    Hi All, I just would like to know why my code isn't working. Here is my VBA code: [CODE=vba]Private Sub OKButton_Click() Dim i As Integer...
  • List box that changes fill color
    Hello, I have gone through so many pages trying to figure this out. I have a 2020 calendar that depending on the day needs to have a certain...
  • Remove duplicates and retain one. Cross-linked cases
    Hi all I ran out of google keywords to use and still couldn't find a reference how to achieve the results of a single count. It would be great if...
  • VBA Copy and Paste With Duplicates
    Hello All, I'm in need of some input. My VBA skills are sub-par at best. I've assembled this code from basic research and it works but is...
  • Macro
    is it possible for a macro to run if the active cell value is different to the value above it
  • IF DATE and TIME
    I currently use this to check if date has passed but i also need to set a time on it too. Is it possible? [CODE=vba]=IF(B:B>TODAY(),"Not...
Top