Cad vba——多段线加相交点

 

Sub AddIntersectionPointsToMultiplePolylines()
    ' yngqq443440204@2024年8月25日12:12:02
    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
    ' 删除已有的选择集，避免冲突
Do
    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
    
    ' 提示用户选择第二批多段线
    ThisDrawing.Utility.Prompt "请选择第二批线，并按空格键结束。"
    selSet2.SelectOnScreen
    If selSet2.Count = 0 Then GoTo erro
    ' 遍历第一批多段线
    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)
            'polyline1.Highlight True: polyline2.Highlight True
           Call AddSelectedPointsToPolyline(polyline1, intersectPoints)

        Next j

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

' 判断选取点(px, py)是否在线段(x1, y1)到(x2, y2)之间
Function IsPointOnLine(x1 As Double, y1 As Double, x2 As Double, y2 As Double, px As Variant, py As Variant) As Boolean
    ' 计算向量 (px - x1, py - y1) 和 (x2 - x1, y2 - y1) 的叉积
    ' crossProduct 是这两个向量的叉积
    Dim crossProduct As Double
    crossProduct = (px - x1) * (y2 - y1) - (py - y1) * (x2 - x1)
     distance = Sqr((x2 - x1) ^ 2 + (y2 - y1) ^ 2)
     distance1 = Sqr((px - x1) ^ 2 + (py - y1) ^ 2)
     distance2 = Sqr((px - x2) ^ 2 + (py - y2) ^ 2)
     If distance < 0.001 Or distance1 < 0.001 Or distance2 < 0.001 Then
        IsPointOnLine = False
        Exit Function
    End If
    ' 如果叉积不为零（或在误差范围内），则说明点不在直线上
    If Abs(crossProduct) > 2 Then '0.1
        IsPointOnLine = False
        Exit Function
    End If

    ' 计算向量 (px - x1, py - y1) 与向量 (x2 - x1, y2 - y1) 的点积
    Dim dotProduct As Double
    dotProduct = (px - x1) * (x2 - x1) + (py - y1) * (y2 - y1)

    ' 如果点积小于0，说明点在起点(x1, y1)外
    If dotProduct < 0 Then
        IsPointOnLine = False
        Exit Function
    End If

    ' 计算向量 (x2 - x1, y2 - y1) 的平方长度
    Dim squaredLengthBA As Double
    squaredLengthBA = (x2 - x1) * (x2 - x1) + (y2 - y1) * (y2 - y1)

    ' 如果点积大于线段的平方长度，说明点在终点(x2, y2)外
    If dotProduct > squaredLengthBA Then
        IsPointOnLine = False
        Exit Function
    End If

    ' 如果上述检查都通过，说明点在直线段上
    IsPointOnLine = True
End Function

Function AddSelectedPointsToPolyline(polyline As AcadLWPolyline, selectedPoints As Variant)
    On Error Resume Next
    'Dim polyline As AcadLWPolyline  ' 存储已知的多段线
    Dim polylineCoords() As Double  ' 存储多段线的顶点坐标（二维数组）
    Dim arrselectedPoints() As Variant  ' 存储选定的点坐标（一维数组，格式：x1, y1, x2, y2, ..., xn, yn）
    Dim newVertices() As Double     ' 存储更新后的顶点坐标数组
    Dim oldVertexCount As Integer   ' 原多段线顶点数量
    Dim newVertexCount As Integer   ' 新顶点数量
    Dim i As Integer, j As Integer
'    For i = 0 To UBound(selectedPoints)
'    arrselectedPoints(i) = selectedPoints(i)
'    Next i
    ' 获取多段线对象和顶点坐标
    polylineCoords = polyline.Coordinates
    oldVertexCount = UBound(polylineCoords) + 1 ' 获取原多段线顶点的数量（二维数组，包含x、y）
    ' 获取用户选定的若干点
    Dim numPoints As Integer
    numPoints = (UBound(selectedPoints) + 1) / 3
   ' ReDim selectedPoints(3 * numPoints - 1)
    ' 初始化新顶点数组
    newVertexCount = oldVertexCount + (UBound(selectedPoints) + 1) * 2 / 3 ' 最大长度为旧顶点数量 + 选点数量
    ReDim newVertices(newVertexCount - 1)
    ' 初始化插入点标志
    Dim pointsInserted() As Boolean
    ReDim pointsInserted(numPoints - 1)

    ' 复制旧顶点到新顶点数组，并插入选取的点
    Dim newIndex As Integer
    newIndex = 0
    For i = 1 To (oldVertexCount / 2) - 1
        ' 获取当前顶点和下一个顶点的x, y坐标
        Dim x1 As Double, y1 As Double
        Dim x2 As Double, y2 As Double
        x1 = polylineCoords(2 * i - 2)
        y1 = polylineCoords(2 * i - 1)
        x2 = polylineCoords(2 * i)
        y2 = polylineCoords(2 * i + 1)

        ' 先将当前顶点添加到新数组
        newVertices(newIndex) = x1
        newVertices(newIndex + 1) = y1
        newIndex = newIndex + 2

        ' 插入选定的所有点，按顺序处理
        For j = 0 To numPoints - 1
            If Not pointsInserted(j) Then
                If IsPointOnLine(x1, y1, x2, y2, selectedPoints(3 * j), selectedPoints(3 * j + 1)) Then
                    newVertices(newIndex) = selectedPoints(3 * j)
                    newVertices(newIndex + 1) = selectedPoints(3 * j + 1)
                    newIndex = newIndex + 2
                    pointsInserted(j) = True
                End If
            End If
        Next j
    Next i

    ' 添加最后一个顶点（因循环中略过了最后一个顶点）
    newVertices(newIndex) = polylineCoords(oldVertexCount - 2)
    newVertices(newIndex + 1) = polylineCoords(oldVertexCount - 1)
    ReDim Preserve newVertices(newIndex + 1)
    ' 更新多段线的顶点坐标
    polyline.Coordinates = newVertices
    polyline.Update
End Function
Function SimplifyPolyline(objPolyline As AcadLWPolyline)
    'Dim objPolyline As AcadLWPolyline   ' 声明一个多段线对象
    Dim i As Integer                    ' 迭代器
    Dim vertexCount As Integer          ' 顶点数量
    Dim point1 As Variant, point2 As Variant  ' 用于存储两个顶点的坐标
    Dim distance As Double              ' 用于存储两个顶点之间的距离
    Dim newcoords() As Double
    'ThisDrawing.Utility.GetEntity objPolyline, mypt
    Dim isclosed As Boolean
    isclosed = objPolyline.Closed
     coords = objPolyline.Coordinates  ' 获取多段线的所有坐标
    vertexCount = (UBound(coords) + 1) / 2 ' 获取顶点的数量
     ' 初始化新的顶点坐标数组
    ReDim newcoords(0 To UBound(coords))
    newIndex = 0
     ' 将第一个顶点加入新数组
    newcoords(newIndex) = coords(0)
    newcoords(newIndex + 1) = coords(1)
    newIndex = newIndex + 2
    ' 从第二个顶点开始检查距离并处理
    For i = 2 To vertexCount
        ' 获取当前顶点和前一个顶点的坐标
        point1 = Array(coords(2 * (i - 2)), coords(2 * (i - 2) + 1))
        point2 = Array(coords(2 * (i - 1)), coords(2 * (i - 1) + 1))

        ' 计算两个顶点之间的距离
        distance = Sqr((point1(0) - point2(0)) ^ 2 + (point1(1) - point2(1)) ^ 2)

        ' 如果距离大于等于0.001，则将当前顶点加入新数组
        If distance > 0.001 Then
            newcoords(newIndex) = point2(0)
            newcoords(newIndex + 1) = point2(1)
            newIndex = newIndex + 2
        End If
    Next i

    ' 删除原来的多段线
   ReDim Preserve newcoords(0 To newIndex - 1)
     objPolyline.Coordinates = newcoords
    objPolyline.Update

End Function