026集—CAD中多段线批量增加折点（相交点）——vba代码实现

当需要批量在多段线中加入顶点（与多段线相交的点）时，如下图所示：若干条线相交：

我们想在相交处增加折点，可通过vba插件一键完成。

（使用方法命令行输入：vbaman,加载插件，vbarun,运行插件即可。）

 

 同时，本插件支持闭合图形增加相交点为顶点：

当多次执行此程序，多段线不会增加大量重复相交点，避免产生大量距离过近的点、重复点。

另附部分源代码可供参考:

Sub AddIntersectionPointsToMultiplePolylines()
    ' yngqq443440204@2024年8月25日10:41:30
    On Error Resume Next
    Dim polyline1 As AcadLWPolyline ' 用于存储第一批中的单个多段线
    Dim polyline2 As AcadLWPolyline ' 用于存储第二批中的单个多段线
    Dim intersectPoints As Variant ' 用于存储交点
    Dim newVertices() As Double ' 用于存储新的顶点
    Dim oldVertices As Variant ' 用于存储原有的顶点
    Dim selSet1 As AcadSelectionSet ' 第一批多段线的选择集
    Dim selSet2 As AcadSelectionSet ' 第二批多段线的选择集
    Dim i As Integer, j As Integer, k As Integer
    Dim vertexCount As Integer
    Dim vertexinserted As Boolean
    ' 删除已有的选择集，避免冲突

    On Error Resume Next
    ThisDrawing.SelectionSets.Item("selSet1").Delete
    ThisDrawing.SelectionSets.Item("selSet2").Delete
    On Error GoTo 0
    Set selSet1 = ThisDrawing.SelectionSets.Add("selSet1")
    Set selSet2 = ThisDrawing.SelectionSets.Add("selSet2")
    ThisDrawing.Utility.Prompt "请选择第一批需要加点的线，并按空格键结束。"
    selSet1.SelectOnScreen
    If selSet1.Count = 0 Then GoTo erro
       If selSet1.Count = 0 Then GoTo erro
    ' 提示用户选择第二批多段线
    ThisDrawing.Utility.Prompt "请选择第二批线，并按空格键结束。"
    selSet2.SelectOnScreen
    ' 遍历第一批多段线
    For i = 0 To selSet1.Count - 1
        ' 获取当前第一批多段线
        Set polyline1 = selSet1.Item(i)
        'Call SimplifyPolyline(polyline1)

        ' 初始化一个新数组用于存储当前多段线的所有顶点
        oldVertices = polyline1.Coordinates
        vertexCount = UBound(oldVertices) + 1
        ' 遍历第二批多段线
        For j = 0 To selSet2.Count - 1
            ' 获取当前第二批多段线
            Set polyline2 = selSet2.Item(j)
            ' 查找交点
            intersectPoints = polyline1.IntersectWith(polyline2, acExtendNone)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''
''''省略部分源码，qq完整代码443440204

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        Next j

    Next i

    ThisDrawing.Utility.Prompt "交点已加入到第一批多段线中。"
erro:
    MsgBox "OK，CAD二次开发", , "443440204"
End Sub