如何用VBA（非Excel）检测几何图形中的闭合与开环？

核心思路：依托线条连接关系的路径遍历与闭合判断 #

1. 数据预处理：构建连接索引 #

• 对所有线条的起止坐标做精度归一化（比如保留4位小数），避免浮点误差导致的连接误判
• 建立两个字典映射：
  • startPointMap：键为起点坐标字符串，值为所有以该点为起点的线条ID集合
  • endPointMap：键为终点坐标字符串，值为所有以该点为终点的线条ID集合
• 给每条线条添加IsVisited标记，初始值设为False

2. 开环识别 #

• 遍历所有线条，若某条线条的起点不在endPointMap中、终点不在startPointMap中，直接标记为开环
• 若线条仅一端有匹配连接点，从该端开始遍历延伸，直到无法继续，整个路径标记为开环（比如你提到的顶部竖直线）

3. 闭合环识别（支持共享几何） #

方法：深度优先遍历（DFS）的路径追踪

• 遍历所有未访问的线条，以其起点为起始点启动路径追踪：
  1. 记录当前路径的线条序列，标记当前线条为已访问
  2. 从当前线条的终点，查找startPointMap中对应的线条（若允许共享几何，取消未访问限制，但需检查路径避免循环）
  3. 若路径终点回到起始点，且路径长度≥3（排除单线条/双线条的无效闭合），判定为闭合环
  4. 若遍历到无后续线条的节点，回溯至分支点尝试其他路径
• 共享几何处理：允许线条被多环引用，但需记录当前路径的节点序列，避免进入无限循环（比如判断下一条线的终点是否已在当前路径节点中，且不是起始点）

4. 环的内外层级区分（可选） #

• 对已识别的闭合环，取环内任意点（如中心点）使用改进版射线法：
  • 向任意方向投射射线，仅统计与闭合环线条的交点数（开环线条不参与）
  • 交点数为奇数时，该环为内轮廓；偶数时为外轮廓（外轮廓交点数为0，属于偶数）
  • 注意：微调射线起点坐标，避免射线恰好穿过线条端点

VBA代码片段示例 #

' 定义线条数据结构
Type LineSegment
    ID As Integer
    StartX As Double
    StartY As Double
    EndX As Double
    EndY As Double
    IsVisited As Boolean
End Type

' 构建连接映射字典
Sub BuildConnectionMaps(lines() As LineSegment, startMap As Object, endMap As Object)
    Set startMap = CreateObject("Scripting.Dictionary")
    Set endMap = CreateObject("Scripting.Dictionary")
    
    Dim i As Integer, key As String
    For i = LBound(lines) To UBound(lines)
        ' 坐标转字符串作为键，保留4位小数消除浮点误差
        key = Round(lines(i).StartX, 4) & "," & Round(lines(i).StartY, 4)
        If Not startMap.Exists(key) Then Set startMap(key) = New Collection
        startMap(key).Add lines(i).ID
        
        key = Round(lines(i).EndX, 4) & "," & Round(lines(i).EndY, 4)
        If Not endMap.Exists(key) Then Set endMap(key) = New Collection
        endMap(key).Add lines(i).ID
    Next i
End Sub

' 检测所有闭合环
Sub DetectClosedLoops(lines() As LineSegment, startMap As Object, endMap As Object, closedLoops As Collection)
    Set closedLoops = New Collection
    Dim currentPath As New Collection, startKey As String
    
    For i = LBound(lines) To UBound(lines)
        If Not lines(i).IsVisited Then
            startKey = Round(lines(i).StartX, 4) & "," & Round(lines(i).StartY, 4)
            currentPath.Add lines(i).ID
            lines(i).IsVisited = True
            TraceLoop lines, startMap, endMap, startKey, lines(i).EndX, lines(i).EndY, currentPath, closedLoops
            currentPath.Clear
        End If
    Next i
End Sub

' 递归追踪环路径（支持共享几何的回溯）
Sub TraceLoop(lines() As LineSegment, startMap As Object, endMap As Object, startKey As String, currX As Double, currY As Double, currentPath As Collection, closedLoops As Collection)
    Dim currKey As String, col As Collection, lineID As Integer, line As LineSegment
    currKey = Round(currX, 4) & "," & Round(currY, 4)
    
    ' 回到起点，形成有效闭合环
    If currKey = startKey Then
        If currentPath.Count >= 3 Then
            Dim loopCopy As New Collection
            For Each id In currentPath
                loopCopy.Add id
            Next id
            closedLoops.Add loopCopy
        End If
        Exit Sub
    End If
    
    ' 查找当前点作为起点的线条
    If startMap.Exists(currKey) Then
        Set col = startMap(currKey)
        For Each lineID In col
            Set line = lines(lineID)
            ' 若允许共享几何，可替换Not line.IsVisited为路径节点检查，避免循环
            If Not line.IsVisited Then
                line.IsVisited = True
                currentPath.Add lineID
                TraceLoop lines, startMap, endMap, startKey, line.EndX, line.EndY, currentPath, closedLoops
                currentPath.Remove currentPath.Count
                line.IsVisited = False ' 回溯，允许其他环复用该线条
            End If
        Next lineID
    End If
End Sub

关键注意事项 #

• 浮点精度：必须对坐标做归一化处理，否则会出现连接点误判
• 共享几何回溯：追踪环时，回溯阶段要取消线条的已访问标记，确保其他路径可复用
• 开环补充：除孤立线条外，需识别那些一端有连接但无法闭合的路径，这类也属于开环

内容的提问来源于stack exchange，提问作者G.H.