027集—CAD中批量删除多段线重复点、距离过近点——vba代码实现

cad图中多段线存在重复点、或距离过近点，可通过vba插件一键删除。

（精度可人工设定，例如精度设置0.001：小于0.001 的点视为重复点，删除此点。）

如下图：

 如下图：

大量重复点和距离过近点：

 

运行dvb插件（使用方法：命令行输入vbaman,加载此dvb插件，输入vbarun运行，选择多段线即可。）

另附部分源代码：

Sub AddIntersectionPointsToMultiplePolylines()
     'yngqq443440204@2024年8月25日10:41:30
    'On Error Resume Next
    Dim polyline1 As AcadLWPolyline ' 用于存储第一批中的单个多段线
    Dim selSet1 As AcadSelectionSet ' 第一批多段线的选择集
    Dim selSet2 As AcadSelectionSet ' 第二批多段线的选择集
    Dim i As Integer
    On Error Resume Next
    ThisDrawing.SelectionSets.Item("selSet1").Delete
    On Error GoTo 0
    Set selSet1 = ThisDrawing.SelectionSets.Add("selSet1")
    ThisDrawing.Utility.Prompt "请选择第一批需要加点的线，并按空格键结束。"
    selSet1.SelectOnScreen
    If selSet1.Count = 0 Then GoTo erro
    For i = 0 To selSet1.Count - 1
        Set polyline1 = selSet1.Item(i)
        'Call SimplifyPolyline(polyline1)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''省略部分源码，qq完整代码443440204
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Next i
    ThisDrawing.Utility.Prompt "交点已加入到第一批多段线中。"
erro:
    MsgBox "OK，CAD二次开发", , "443440204"
End Sub