|
These ArcMap VBA Scripts create HTML tables of all the USGS Quads, their centroid coordinates, an associated county, and links to download them. One script sorts the resulting table by SGID Quad Number, the other by USGS Quad Name.The scripts assume that there are two layers in an ArcMap Project. The first layer (0) is the SGID.U024.CountyBoundaries and the second layer (1) is SGID.U024.USGS24KQuads. These tables are used on the gis.utah.gov portal for the following content: VBA Code:
Public Sub QuadNumTable()
Open "C:/temp/quadnumout.html" For Output As #1
Dim pMxDoc As IMxDocument
Dim pMap As IMap
Set pMxDoc = ThisDocument
Set pMap = pMxDoc.FocusMap
Dim pCoFlayer As IFeatureLayer
Dim pQFLayer As IFeatureLayer
Dim pQFC As IFeatureClass
Dim pCoFC As IFeatureClass
Set pCoFlayer = pMap.Layer(0)
Set pQFLayer = pMap.Layer(1)
Set pQFC = pQFLayer.FeatureClass
Set pCoFC = pCoFlayer.FeatureClass
Dim pTableSort As ITableSort
Set pTableSort = New TableSort
Set pTableSort.Table = pQFC
pTableSort.Fields = "LOCATION"
pTableSort.Ascending("LOCATION") = True
pTableSort.Sort Nothing
Dim pQFCursor As IFeatureCursor
Dim pQFeature As IFeature
Set pQFCursor = pTableSort.Rows
Set pQFeature = pQFCursor.NextFeature
Dim QName As String
Dim QNum As String
Dim QOhio As String
Dim CoString As String
Dim pQPoly As IArea
Dim pQPoint As IPoint
Dim centerXY As String
Dim centerCounty As String
Print #1, "<table>"
Print #1, " <tr>"
Print #1, " <td><b>Quad Number</b></td>"
Print #1, " <td><b>Quad Name</b></td>"
Print #1, " <td><b>Ohio Code </b></td>"
Print #1, " <td><b>Center, UTM NAD83 </b></td>"
Print #1, " <td><b>Center*, County</b></td>"
Print #1, " </tr>" Do Until pQFeature Is Nothing
QNum = pQFeature.Value(pQFC.FindField("LOCATION"))
QName = pQFeature.Value(pQFC.FindField("NAME"))
QOhio = pQFeature.Value(pQFC.FindField("OHIO_CODE"))
Set pQPoly = pQFeature.Shape
Set pQPoint = pQPoly.Centroid
centerXY = CLng(pQPoint.Y) & "N " & CLng(pQPoint.X) & "E"
Dim pSpatialFilter As ISpatialFilter
Set pSpatialFilter = New SpatialFilter
Set pSpatialFilter.Geometry = pQPoint
pSpatialFilter.SpatialRel = esriSpatialRelWithin
Dim pCoCursor As ICursor
Dim pCoRow As IRow
Set pCoCursor = pCoFlayer.FeatureClass.Search(pSpatialFilter, False)
Set pCoRow = pCoCursor.NextRow
If pCoRow Is Nothing Then
Set pSpatialFilter.Geometry = pQPoly
pSpatialFilter.SpatialRel = esriSpatialRelIntersects
Set pCoCursor = pCoFC.Search(pSpatialFilter, False)
Set pCoRow = pCoCursor.NextRow
End If
Print #1, " <tr>"
Print #1, " <td><a href=""ftp://ftp.agrc.utah.gov/DRG_83/" & LCase(QNum) & "_drg24.zip"">" & QNum & "</a></td>"
Print #1, " <td>" & QName & "</td>"
Print #1, " <td>" & QOhio & "</td>"
Print #1, " <td>" & centerXY & "</td>"
If Not pCoRow Is Nothing Then
Print #1, " <td>" & pCoRow.Value(pCoFC.FindField("NAME")) & "</td>"
Else
Print #1, " <td>n/a</td>"
End If
Print #1, " </tr>"
Set pQFeature = pQFCursor.NextFeature
Loop
Print #1, "</table>"
Print #1, "<p>* Shows the Utah county that is at the quads centeroid, or if centroid is not available, a county that interesects the quad.</p>"
Close #1
End Sub
Public Sub QuadNameTable()
Open "C:/temp/quadnameout.html" For Output As #1
Dim pMxDoc As IMxDocument
Dim pMap As IMap
Set pMxDoc = ThisDocument
Set pMap = pMxDoc.FocusMap
Dim pCoFlayer As IFeatureLayer
Dim pQFLayer As IFeatureLayer
Dim pQFC As IFeatureClass
Dim pCoFC As IFeatureClass
Set pCoFlayer = pMap.Layer(0)
Set pQFLayer = pMap.Layer(1)
Set pQFC = pQFLayer.FeatureClass
Set pCoFC = pCoFlayer.FeatureClass
Dim pTableSort As ITableSort
Set pTableSort = New TableSort
Set pTableSort.Table = pQFC
pTableSort.Fields = "NAME"
pTableSort.Ascending("NAME") = True
pTableSort.Sort Nothing
Dim pQFCursor As IFeatureCursor
Dim pQFeature As IFeature
Set pQFCursor = pTableSort.Rows
Set pQFeature = pQFCursor.NextFeature
Dim QName As String
Dim QNum As String
Dim QOhio As String
Dim CoString As String
Dim pQPoly As IArea
Dim pQPoint As IPoint
Dim centerXY As String
Dim centerCounty As String
Print #1, "<table>"
Print #1, " <tr>"
Print #1, " <td><b>Quad Number</b></td>"
Print #1, " <td><b>Quad Name</b></td>"
Print #1, " <td><b>Ohio Code </b></td>"
Print #1, " <td><b>Center, UTM NAD83 </b></td>"
Print #1, " <td><b>Center*, County</b></td>"
Print #1, " </tr>" Do Until pQFeature Is Nothing
QNum = pQFeature.Value(pQFC.FindField("LOCATION"))
QName = pQFeature.Value(pQFC.FindField("NAME"))
QOhio = pQFeature.Value(pQFC.FindField("OHIO_CODE"))
Set pQPoly = pQFeature.Shape
Set pQPoint = pQPoly.Centroid
centerXY = CLng(pQPoint.Y) & "N, " & CLng(pQPoint.X) & "E"
Dim pSpatialFilter As ISpatialFilter
Set pSpatialFilter = New SpatialFilter
Set pSpatialFilter.Geometry = pQPoint
pSpatialFilter.SpatialRel = esriSpatialRelWithin
Dim pCoCursor As ICursor
Dim pCoRow As IRow
Set pCoCursor = pCoFlayer.FeatureClass.Search(pSpatialFilter, False)
Set pCoRow = pCoCursor.NextRow
If pCoRow Is Nothing Then
Set pSpatialFilter.Geometry = pQPoly
pSpatialFilter.SpatialRel = esriSpatialRelIntersects
Set pCoCursor = pCoFC.Search(pSpatialFilter, False)
Set pCoRow = pCoCursor.NextRow
End If
Print #1, " <tr>"
Print #1, " <td><a href=""ftp://ftp.agrc.utah.gov/DRG_83/" & LCase(QNum) & "_drg24.zip"">" & QNum & "</a></td>"
Print #1, " <td>" & QName & "</td>"
Print #1, " <td>" & QOhio & "</td>"
Print #1, " <td>" & centerXY & "</td>"
If Not pCoRow Is Nothing Then
Print #1, " <td>" & pCoRow.Value(pCoFC.FindField("NAME")) & "</td>"
Else
Print #1, " <td>n/a</td>"
End If
Print #1, " </tr>"
Set pQFeature = pQFCursor.NextFeature
Loop
Print #1, "</table>"
Print #1, "<p>* Shows the Utah county that is at the quads centeroid, or if centroid is not available, a county that interesects the quad.</p>"
Close #1
End Sub
|
