sflash11
06-21-2017, 07:51 AM
I recently inherited an excel document with a VBA code that was getting a run-time error 5. I am very new to VBA, so this was a large task to debug the code. I was able to get it to run through, it previously wasn't doing that, and have made a few changes to the code. I felt I got the corrected but I ran into trouble with the code still not able to run. I will post the code that I have so far as well as attach the original document I received in case I made changes that really didn't help my case.
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 Integer, x As Integer, y As Integer, SavePDF, SaveImg, c As Integer
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
[Moderator Note: I removed all the Color tags from the Code, Since They don't even work inside Code Formatting Tags.]
I put the code I switched around/added in Green (it has the code dialogue surrounding it). The red is the code which I was getting an error for. Finally, when I can get the program to run through it enters some blank cells for the results periodically, why is this happening?
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 Integer, x As Integer, y As Integer, SavePDF, SaveImg, c As Integer
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
[Moderator Note: I removed all the Color tags from the Code, Since They don't even work inside Code Formatting Tags.]
I put the code I switched around/added in Green (it has the code dialogue surrounding it). The red is the code which I was getting an error for. Finally, when I can get the program to run through it enters some blank cells for the results periodically, why is this happening?