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 <> "" Then
If x > 0 Then
If InStr(arrWebpage, "FAA.gov") <> 0 Then
x = 0
Else
strResult = strResult & arrWebpage & Chr(10)
End If
End If
If InStr(arrWebpage, "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.
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 <> "" Then
If x > 0 Then
If InStr(arrWebpage, "FAA.gov") <> 0 Then
x = 0
Else
strResult = strResult & arrWebpage & Chr(10)
End If
End If
If InStr(arrWebpage, "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.