|
Updated 2/11/09: We dusted this script off, made a few changes and used it successfully with 9.3 file geodatabase and 9.2 versioned SDE data layers. This shoud be a valuable tool for working on street layer connectivity. This VBA script for ArcMap attempts to find dead end and cul de sac street features that are responsible for creating dangle errors in a geodatabase topology and mark them as exceptions. The area within a specified buffer distance (default = 10 meters) of each error is searched for street features. If only one street feature is found, the error is likely a legitimate dead end and the feature is marked as an exception. The graphics above show thousands of dangle node topology errors before running the script. After the script has been run, most of these have been marked as exceptions allowing the editor to focus on the most likely topologic connectivity errors.
Option Explicit Sub markDeadEndStreetFeaturesAsExceptions()
On Error GoTo errorhandler
' AGRC updated 02/17/2009 to use ErrorFeaturesByRuleType instead of ErrorFeaturesByGeometryType
' AGRC updated 04/20/09 to include possibility of using an envelope filter to work locally in an area
'
'
' --> NOW WORKS IN FILE GDB, AND SDE <--
'
' DESCRIPTION:
' This script attempts to find dead end and cul de sac street
' features that are responsible for creating dangle errors in a
' geodatabase topology and mark them as exceptions. The area within
' the buffer distance of each error is searched for street features.
' If only one street feature is found, the error is likely a
' legitimate dead end and the feature is marked as an exception.
'
' REQUIREMENTS:
' -- This script must be run on a validated topology
' with a no dangle topology rule defined.
'
' NOTES:
' -- Refresh data view after running script.
'
' -- Edit session must be saved to persist edits in geodatabase. Check to
' make sure results are satisfactory before saving.
'
' SCRIPT PARAMETERS (SET THESE BEFORE RUNNING):
' ***** If only one street feature is found wth in buffDist of error,
' ***** the error gets marked as an exception. Setting this too low will
' ***** mark real errors as exceptions.
Dim buffDist As Double
buffDist = 10 'in topology's feature dataset defined linear units
' ***** Index Number of Roads Layer in TOC
Dim rdLayerIndexNumber As Integer
rdLayerIndexNumber = 1 'an index of 1 refers to the second layer in TOC
Dim pMxDoc As IMxDocument
Dim pMap As IMap
Set pMxDoc = ThisDocument
Set pMap = pMxDoc.FocusMap
Dim pRDFLayer As IFeatureLayer
Set pRDFLayer = pMap.Layer(rdLayerIndexNumber)
Dim pFC As IFeatureClass
Dim pDataset As IDataset
Dim pWS As IWorkspace
Dim pWSEdit As IWorkspaceEdit
Set pFC = pRDFLayer.FeatureClass
Dim pGDS As IGeoDataset
Set pGDS = pFC
Set pDataset = pFC ' QI
Set pWS = pDataset.Workspace
Dim GeoType As esriGeometryType
GeoType = esriGeometryPoint
Dim pTopologyExtension As ITopologyExtension
Dim pUID As New UID
Dim pEnumTopologyErrorFeature As IEnumTopologyErrorFeature
Dim pErrorContainer As IErrorFeatureContainer
Dim pTopoErrFeature As ITopologyErrorFeature
Dim pGeoDS As IGeoDataset
Dim pTopology As ITopology
Dim pEditor As IEditor
Dim pRdFCursor As IFeatureCursor
Dim pRdFeature As IFeature
Dim pSF As ISpatialFilter
Dim pExcepTopOp As ITopologicalOperator
Dim pExcepPt As IPoint
Dim pBuffPolygon As IPolygon
Dim rdCount As Integer
Dim pTopologyRuleContainer As ITopologyRuleContainer
Dim pErrCounter As Long
pUID = "esriEditor.Editor"
Set pEditor = Application.FindExtensionByCLSID(pUID)
'Set pWSEdit = pWS
pUID = "esriEditorExt.TopologyExtension"
Set pTopologyExtension = Application.FindExtensionByCLSID(pUID)
If pEditor.EditState = esriStateEditing Then
MsgBox "You must not currently be in an edit session to run this script.", vbOKOnly, "Exiting"
Exit Sub
Else
pEditor.StartEditing pWS
pEditor.StartOperation
End If
Set pTopology = pTopologyExtension.CurrentTopology
Set pGeoDS = pTopology
Set pTopologyRuleContainer = pTopology
Dim pExcepFeat As IFeature
If pTopologyExtension.ActiveErrorCount = 0 Then
'MsgBox pTopologyExtension.ActiveErrorCount
Set pErrorContainer = pTopology
Set pEnumTopologyErrorFeature = pErrorContainer.ErrorFeaturesByRuleType(pGeoDS.SpatialReference, esriTRTLineNoDangles, pGDS.Extent, True, False)
pTopologyExtension.ClearActiveErrors esriTENone
Set pTopoErrFeature = pEnumTopologyErrorFeature.Next
pTopologyExtension.DelayEvents True
Do While Not pTopoErrFeature Is Nothing
pErrCounter = pErrCounter + 1
If pErrCounter / 1000 = CLng(pErrCounter / 1000) Then
Debug.Print "dangles: " & (pErrCounter - 1000) & "-" & pErrCounter & " " & Now
pEditor.StopOperation "dangles: " & (pErrCounter - 1000) & "-" & pErrCounter
pEditor.StartOperation
End If
If pTopoErrFeature.IsException = False Then
Set pExcepFeat = pTopoErrFeature
Set pExcepPt = pExcepFeat.Shape
'**** optional envelope filter
'**** use something like this to target a specific area and
'**** uncomment the end if 15 or so lines below, too
'If pExcepPt.X > 230000 And pExcepPt.X < 370000 And _
pExcepPt.Y > 4350000 And pExcepPt.y < 4380000 Then
Set pExcepTopOp = pExcepPt
Set pBuffPolygon = pExcepTopOp.Buffer(buffDist)
Set pSF = New SpatialFilter
Set pSF.Geometry = pBuffPolygon
pSF.SpatialRel = esriSpatialRelIntersects
Set pRdFCursor = pRDFLayer.Search(pSF, False)
Set pRdFeature = pRdFCursor.NextFeature
rdCount = 0
Do Until pRdFeature Is Nothing
rdCount = rdCount + 1
Set pRdFeature = pRdFCursor.NextFeature
Loop
If rdCount < 2 Then
If Not pTopoErrFeature.IsException Then
pTopologyRuleContainer.PromoteToRuleException pTopoErrFeature
End If
End If
'**** end if 'must uncomment if using the envelope filter
End If
Set pTopoErrFeature = pEnumTopologyErrorFeature.Next
Loop
pEditor.StopOperation "Dangle Exception Analysis"
pTopologyExtension.TopologySelectionChanged
pTopologyExtension.DelayEvents False
pEditor.StopEditing True
End If
Exit Sub
errorhandler:
Debug.Print pTopoErrFeature.OriginOID
Exit Sub
Resume Next
End Sub
|
