Here is the full code.I have stepped through it several times and identified areas where I was setting variables inside instead of outside loops and things like that, but I can't see any more of those issues.Thanks for your help 🙂Private Sub Downstream_Click()
'Get each of the three layers and feature classes (Rivers, Dams, and CSL)
Dim pMxDoc As IMxDocument
Set pMxDoc = ThisDocument
Dim pMap As IMap
Set pMap = pMxDoc.FocusMap
Dim pActiveView As IActiveView
Set pActiveView = pMxDoc.ActiveView
Dim pRiversL As IFeatureLayer
Set pRiversL = pMap.Layer(0) 'Rivers
Dim pRiversFC As IFeatureClass
Set pRiversFC = pRiversL.FeatureClass
Dim pDamsL As IFeatureLayer
Set pDamsL = pMap.Layer(1) 'Dams
Dim pDamsFC As IFeatureClass
Set pDamsFC = pDamsL.FeatureClass
Dim pCSLL As IFeatureLayer
Set pCSLL = pMap.Layer(2) 'CSL
Dim pCSLFC As IFeatureClass
Set pCSLFC = pCSLL.FeatureClass
'Begin looping through the Dams
Dim pDamCursor As IFeatureCursor
Set pDamCursor = pDamsFC.Search(Nothing, False)
Dim pDamF As IFeature
Set pDamF = pDamCursor.NextFeature
Dim DamNumber As Integer
DamNumber = 0
Do Until pDamF Is Nothing
DamNumber = DamNumber + 1
Debug.Print "Beginning Dam Number " & DamNumber & "..."
'Find the river segment that intersects with the dam
Dim pDam As IPoint
Set pDam = pDamF.Shape
Dim pTopoOp As ITopologicalOperator
Set pTopoOp = pDam
Dim BufferPoly As IPolygon
Set BufferPoly = pTopoOp.Buffer(pMxDoc.SearchTolerance)
Dim pSF As ISpatialFilter
Set pSF = New SpatialFilter
With pSF
Set .Geometry = BufferPoly
.GeometryField = "Shape"
.SpatialRel = esriSpatialRelIndexIntersects
End With
Dim pRivCursor As IFeatureCursor
Set pRivCursor = pRiversFC.Search(pSF, False)
Dim pRiverF As IFeature
Set pRiverF = pRivCursor.NextFeature
'Get the length of the current segment
Dim pRiver As IPolycurve
Set pRiver = pRiverF.Shape
Dim RiverLength As Double
RiverLength = pRiver.Length
'Create a point on the river nearest the dam
Dim pProxOp As IProximityOperator
Set pProxOp = pRiver
Dim pDamPoint As IPoint
Set pDamPoint = pProxOp.ReturnNearestPoint(pDam, esriNoExtension)
'Create a vertex in the river at that point
Dim PartIndex As Long
Dim SegIndex As Long
Dim SplitHap As Boolean
pRiver.SplitAtPoint pDamPoint, True, False, SplitHap, PartIndex, SegIndex
Debug.Print SplitHap
'Find the distance to the point
Dim DistToDam As Double
Dim NearDist As Double
Dim Length As Double
Dim pDamPoint2 As IPoint
Set pDamPoint2 = New Point
Dim Right As Boolean
pRiver.QueryPointAndDistance esriNoExtension, pDam, False, pDamPoint2, DistToDam, NearDist, Right
Length = RiverLength - DistToDam
Debug.Print "Distance to Dam #" & DamNumber & ": " & DistToDam
Dim pRiverSeg As IPolycurve
Set pRiverSeg = pRiver
Dim pNextRiver As IPolyline
Dim pNextFromPoint As IPoint
Dim pNextToPoint As IPoint
Dim pToPoint As IPoint
Dim LoopCount1 As Integer
Dim pTopoOpUnion As ITopologicalOperator
Set pTopoOpUnion = pRiverSeg
LoopCount1 = 0
'Keep going until length of segments downstream of the dam is greater than 500m
Do Until Length >= 500
LoopCount1 = LoopCount1 + 1
Debug.Print "Finding downstream segments, Iteration # " & LoopCount1 & "..."
If LoopCount1 = 1 Then
Set pToPoint = pRiver.ToPoint
ElseIf LoopCount1 > 1 Then
'Do Nothing
End If
'Find segments that intersect with the last segment's to-point
Set pTopoOp = pToPoint
Set BufferPoly = pTopoOp.Buffer(pMxDoc.SearchTolerance)
With pSF
Set .Geometry = BufferPoly
.GeometryField = "Shape"
.SpatialRel = esriSpatialRelIndexIntersects
End With
Dim pNextCursor As IFeatureCursor
Set pNextCursor = pRiversFC.Search(pSF, False)
Dim pNextRiverF As IFeature
Set pNextRiverF = pNextCursor.NextFeature
Do Until pNextRiverF Is Nothing
'Get the geometry attributes of the intersecting segment
Set pNextRiver = pNextRiverF.Shape
Set pNextFromPoint = pNextRiver.FromPoint
Set pNextToPoint = pNextRiver.ToPoint
'Find out if the intersecting segment is the next downstream segment
If Round(pToPoint.X, 5) = Round(pNextFromPoint.X, 5) Then
If Round(pToPoint.Y, 5) = Round(pNextFromPoint.Y, 5) Then
Debug.Print "Downstream segment found"
Length = Length + pNextRiver.Length 'And add the length of the downstream segment to the total
Set pRiverSeg = pTopoOpUnion.Union(pNextRiver)
'pRiverSeg should now contain the entire length of river
Set pToPoint = pNextRiver.ToPoint
Debug.Print "Total length: " & pRiverSeg.Length
Debug.Print "Length downstream from dam: " & Length
Else:
'Do nothing
End If
Else:
'Do nothing
End If
Set pNextRiverF = pNextCursor.NextFeature
Loop
Debug.Print "Downstream segment confirmed"
Loop
Debug.Print "Downstream segments compiled to be at least 500 metres"
'Get the Subcurve
Dim pSubCurve As IPolycurve
pRiverSeg.GetSubcurve DistToDam, DistToDam + 500, False, pSubCurve
'Select any CSL that intersects with the Subcurve (This curve starts at the dam and extends 500 metres downstream)
Dim pFeatureSelection As IFeatureSelection
Set pFeatureSelection = pCSLL
Set pTopoOp = pSubCurve
Set BufferPoly = pTopoOp.Buffer(pMxDoc.SearchTolerance)
With pSF
Set .Geometry = BufferPoly
.GeometryField = "Shape"
.SpatialRel = esriSpatialRelIndexIntersects
End With
Debug.Print "Searching for CSL intersecting with 500 metre downstream segment..."
Dim pCSLCursor As IFeatureCursor
Set pCSLCursor = pCSLFC.Search(pSF, False)
Dim pCSLF As IFeature
Set pCSLF = pCSLCursor.NextFeature
Dim LoopCount As Integer
LoopCount = 0
Dim Query As String
Do Until pCSLF Is Nothing 'All of these are CSL intersecting with the Subcurve
LoopCount = LoopCount + 1
Debug.Print "Found downstream CSL # " & LoopCount
Dim pCSL As IPoint
Set pCSL = pCSLF.Shape
If LoopCount = 1 Then
Query = "OBJECTID = " & pCSLF.OID
ElseIf LoopCount > 1 Then
Query = Query & " OR OBJECTID = " & pCSLF.OID
End If
Set pCSLF = pCSLCursor.NextFeature
Loop
Debug.Print LoopCount & " Downstream CSL found"
If LoopCount > 0 Then 'Only perform the selection if intersecting CSL were found
Dim pQueryFilter As IQueryFilter
Set pQueryFilter = New QueryFilter
pQueryFilter.WhereClause = Query
pFeatureSelection.SelectFeatures pQueryFilter, esriSelectionResultAdd, False
Debug.Print LoopCount & " Downstream CSL selected"
Else:
'Do Nothing
End If
Set pDamF = pDamCursor.NextFeature
Debug.Print " "
Debug.Print " "
Loop
Debug.Print "completed downstream CSL selection for " & DamNumber & " dams"
pActiveView.Refresh
MsgBox "Done!"
End Sub
