I changed the segment check in WalkChainFromPoint.
I also renamed the constant for ignoring constructional geometries to IGNORE_CONSTRUCTION_GEOMETRY to make it clearer.
I also rewrote GetNextConnectedSegments.
I also added a check at the beginning to ensure the first selected segment is not constructional with Private Const IGNORE_CONSTRUCTION_GEOMETRY As Boolean = True.
I’ll provide the entire new code:
Option Explicit
' ============================================================
' https://forum.cadmunity.com/t/is-there-a-faster-approach/6263
' Macro:Build sketch chain from the user-selected sketch segment.
' 1. Select one sketch segment.
' 2. Run the macro.
' Result:
' The macro finds connected sketch segments in both directions
' from the selected segment and selects the resulting chain.
' Notes:
' - The macro compares SketchPoint objects by reference using "Is" (josh).
' - It does not compare point coordinates.
' - This is important because two points may have the same coordinates
' but still be different sketch points if they are not merged/coincident.
' !!! There shouldn't be any SPLINES or parabola among the segments.
' !!! Processing spline points and finding the exact start and end points requires extensive additional functions.
' << In short, just lines, arcs, and parts of an ellipse. >>
' ============================================================
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swSelMgr As SldWorks.SelectionMgr
' You can include or exclude construction geometry via a constant
Private Const IGNORE_CONSTRUCTION_GEOMETRY As Boolean = False
Sub main()
Dim swStartSeg As SldWorks.SketchSegment
Dim swSketch As SldWorks.Sketch
Dim vAllSegs As Variant
Dim leftChain As Collection
Dim rightChain As Collection
Dim fullChain As Collection
Dim hasBranch As Boolean
Dim hasLoop As Boolean
Dim statusText As String
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then
MsgBox "No active document.", vbExclamation
Exit Sub
End If
Set swSelMgr = swModel.SelectionManager
Set swStartSeg = GetSelectedSketchSegment(swSelMgr)
If swStartSeg Is Nothing Then
MsgBox "Please select one sketch segment and run the macro again.", vbExclamation
Exit Sub
End If
If ShouldUseSegment(swStartSeg) = False Then
MsgBox "The selected segment is construction geometry and is ignored by the current settings.", vbExclamation
Exit Sub
End If
Set swSketch = swStartSeg.GetSketch
If swSketch Is Nothing Then
MsgBox "Could not get parent sketch from selected segment.", vbExclamation
Exit Sub
End If
vAllSegs = swSketch.GetSketchSegments
If IsEmpty(vAllSegs) Then
MsgBox "The sketch does not contain sketch segments.", vbExclamation
Exit Sub
End If
Set leftChain = New Collection
Set rightChain = New Collection
Set fullChain = New Collection
hasBranch = False
hasLoop = False
statusText = ""
' Walk from the start point of the selected segment.
WalkChainFromPoint _
swStartSeg.GetStartPoint2, _
swStartSeg, _
vAllSegs, _
leftChain, _
hasBranch, _
hasLoop, _
statusText
' Walk from the end point of the selected segment.
WalkChainFromPoint _
swStartSeg.GetEndPoint2, _
swStartSeg, _
vAllSegs, _
rightChain, _
hasBranch, _
hasLoop, _
statusText
' Build the final chain:
' left side reversed + selected segment + right side.
BuildFullChain leftChain, swStartSeg, rightChain, fullChain
SelectSegments fullChain
Debug.Print "Selected chain segment count: " & CStr(fullChain.Count)
If hasBranch = True Then
Debug.Print "Result: branch detected."
End If
If hasLoop = True Then
Debug.Print "Result: closed loop or already visited segment detected."
End If
If Len(statusText) > 0 Then
Debug.Print statusText
End If
MsgBox "Chain segments selected: " & CStr(fullChain.Count), vbInformation
End Sub
'Helper function: Get selected segment
Private Function GetSelectedSketchSegment(ByVal swSelMgr As SldWorks.SelectionMgr) As SldWorks.SketchSegment
Dim selectedType As Long
Dim selectedObj As Object
Set GetSelectedSketchSegment = Nothing
If swSelMgr Is Nothing Then
Exit Function
End If
If swSelMgr.GetSelectedObjectCount2(-1) < 1 Then
Exit Function
End If
selectedType = swSelMgr.GetSelectedObjectType3(1, -1)
If selectedType <> swSelSKETCHSEGS And selectedType <> swSelEXTSKETCHSEGS Then
Debug.Print "Selected object type: " & CStr(selectedType)
Exit Function
End If
Set selectedObj = swSelMgr.GetSelectedObject6(1, -1)
If selectedObj Is Nothing Then
Exit Function
End If
Set GetSelectedSketchSegment = selectedObj
End Function
'Basic chain traversal from point
'This procedure proceeds from one point outward.
'For example, if the selected segment is:
'A ---- B
'then the first call comes from A, the second from B.
Private Sub WalkChainFromPoint( _
ByVal startPoint As SldWorks.SketchPoint, _
ByVal previousSegment As SldWorks.SketchSegment, _
ByVal vAllSegs As Variant, _
ByRef resultChain As Collection, _
ByRef hasBranch As Boolean, _
ByRef hasLoop As Boolean, _
ByRef statusText As String)
Dim currentPoint As SldWorks.SketchPoint
Dim prevSeg As SldWorks.SketchSegment
Dim nextSeg As SldWorks.SketchSegment
Dim nextPoint As SldWorks.SketchPoint
Dim connectedSegs As Collection
Dim visitedSegs As Collection
Set currentPoint = startPoint
Set prevSeg = previousSegment
Set visitedSegs = New Collection
' Store the initially selected segment as already visited.
visitedSegs.Add previousSegment
Do
Set connectedSegs = GetNextConnectedSegments(currentPoint, prevSeg, vAllSegs, visitedSegs)
If connectedSegs.Count = 0 Then
' No valid continuation.
' This is a normal endpoint.
Exit Do
ElseIf connectedSegs.Count = 1 Then
' Exactly one valid continuation.
' Continue walking.
Else
' More than one valid continuation after filtering.
' This is a real branch.
hasBranch = True
statusText = statusText & "Branch detected after filtering ignored geometry." & vbCrLf
Exit Do
End If
Set nextSeg = connectedSegs.Item(1)
If SegmentAlreadyExists(nextSeg, visitedSegs) = True Then 'The chain returned to a segment we have already visited. This usually means a closed contour or loop.
hasLoop = True
statusText = statusText & "Loop or already visited segment detected." & vbCrLf
Exit Do
End If
resultChain.Add nextSeg
visitedSegs.Add nextSeg
Set nextPoint = GetOppositePoint(nextSeg, currentPoint)
If nextPoint Is Nothing Then
statusText = statusText & "Could not determine the next sketch point." & vbCrLf
Exit Do
End If
Set prevSeg = nextSeg
Set currentPoint = nextPoint
Loop
End Sub
'Find the next connected segments
'We look for all segments that use the current point: seg.StartPoint Is currentPoint or seg.EndPoint Is currentPoint
'But we exclude the segment we just came from.
Private Function GetNextConnectedSegments( _
ByVal currentPoint As SldWorks.SketchPoint, _
ByVal previousSegment As SldWorks.SketchSegment, _
ByVal vAllSegs As Variant, _
ByVal visitedSegs As Collection) As Collection
Dim result As Collection
Dim i As Long
Dim swSeg As SldWorks.SketchSegment
Set result = New Collection
For i = 0 To UBound(vAllSegs)
Set swSeg = vAllSegs(i)
' First filter out segments that should not participate
' in the chain at all.
If ShouldUseSegment(swSeg) = True Then
' Do not go back through the segment we came from.
If swSeg Is previousSegment Then
' Skip previous segment.
ElseIf SegmentUsesPoint(swSeg, currentPoint) = True Then
' Only add segments that are connected to the current point
' and are not already visited.
If SegmentAlreadyExists(swSeg, visitedSegs) = False Then
result.Add swSeg
End If
End If
End If
Next i
Set GetNextConnectedSegments = result
End Function
'Check: Does the segment use a point?
Private Function SegmentUsesPoint( _
ByVal swSeg As SldWorks.SketchSegment, _
ByVal swPoint As SldWorks.SketchPoint) As Boolean
SegmentUsesPoint = False
If swSeg Is Nothing Then
Exit Function
End If
If swPoint Is Nothing Then
Exit Function
End If
If swSeg.GetStartPoint2 Is swPoint Then
SegmentUsesPoint = True
Exit Function
End If
If swSeg.GetEndPoint2 Is swPoint Then
SegmentUsesPoint = True
Exit Function
End If
End Function
'Getting the opposite point of a segment
'If we entered a segment through one point, we need to exit through another.
Private Function GetOppositePoint( _
ByVal swSeg As SldWorks.SketchSegment, _
ByVal knownPoint As SldWorks.SketchPoint) As SldWorks.SketchPoint
Set GetOppositePoint = Nothing
If swSeg Is Nothing Then
Exit Function
End If
If knownPoint Is Nothing Then
Exit Function
End If
If swSeg.GetStartPoint2 Is knownPoint Then
Set GetOppositePoint = swSeg.GetEndPoint2
Exit Function
End If
If swSeg.GetEndPoint2 Is knownPoint Then
Set GetOppositePoint = swSeg.GetStartPoint2
Exit Function
End If
End Function
'Check for segment repetition
Private Function SegmentAlreadyExists( _
ByVal swSeg As SldWorks.SketchSegment, _
ByVal segCollection As Collection) As Boolean
Dim i As Long
Dim testSeg As SldWorks.SketchSegment
SegmentAlreadyExists = False
If swSeg Is Nothing Then
Exit Function
End If
For i = 1 To segCollection.Count
Set testSeg = segCollection.Item(i)
If testSeg Is swSeg Then
SegmentAlreadyExists = True
Exit Function
End If
Next i
End Function
'Segment filter. Currently only for "construction geometry," but others can be added, such as ignoring ellipses.
Private Function ShouldUseSegment(ByVal swSeg As SldWorks.SketchSegment) As Boolean
ShouldUseSegment = False
If swSeg Is Nothing Then
Exit Function
End If
If IGNORE_CONSTRUCTION_GEOMETRY = True Then
If CBool(swSeg.ConstructionGeometry) Then
Exit Function
End If
End If
ShouldUseSegment = True
End Function
'Assembling the complete chain
'The left side was found from the selected segment outward. Therefore, to ensure proper order, it must be reversed.
Private Sub BuildFullChain( _
ByVal leftChain As Collection, _
ByVal startSegment As SldWorks.SketchSegment, _
ByVal rightChain As Collection, _
ByRef fullChain As Collection)
Dim i As Long
For i = leftChain.Count To 1 Step -1
fullChain.Add leftChain.Item(i)
Next i
fullChain.Add startSegment
For i = 1 To rightChain.Count
fullChain.Add rightChain.Item(i)
Next i
End Sub
'Selecting found segments. Or call a function to process the chain.
Private Sub SelectSegments(ByVal segCollection As Collection)
Dim i As Long
Dim swSeg As SldWorks.SketchSegment
Dim swSelData As SldWorks.SelectData
Dim boolstatus As Boolean
Set swSelData = swModel.SelectionManager.CreateSelectData
swModel.ClearSelection2 True
For i = 1 To segCollection.Count
Set swSeg = segCollection.Item(i)
If i = 1 Then
boolstatus = swSeg.Select4(False, swSelData)
Else
boolstatus = swSeg.Select4(True, swSelData)
End If
If boolstatus = False Then
Debug.Print "Failed to select segment index: " & CStr(i)
End If
Next i
End Sub
≠
