Option Explicit

'正确的删除复合线多余结点过程
'错误的见DelOverlayVertex_Wrong过程
'但是DelOverlayVertex_Wrong能一次得到一组正确的坐标

Public Sub DelOverlayVertex()
'On Error Resume Next
  '定义选择集
  Dim LwPOlvtSelset As AcadSelectionSet
  Set LwPOlvtSelset = CreateSelectionSet
    
  '建立选择集过滤器
  Dim TypeArray As Variant
  Dim DateArray As Variant
  BuildFilter TypeArray, DateArray, 0, "LWPOLYLINE", 8, "jmd"
 
  LwPOlvtSelset.Select acSelectionSetAll, , , TypeArray, DateArray
 
  Dim LwPOlvt As AcadLWPolyline
  Dim i As Integer  '选择集的个数
  Dim k As Integer  '单个lwpolyline的结点
  '定义新旧结点
  Dim PtVtxOld As Variant
  Dim NewVtxCor() As Double
  ReDim Preserve NewVtxCor(1)
  '定义新坐标数组上维
  Dim UBound_K As Integer
 
  Dim d As Double   '定义结点距离
 
  Dim PtVtxAX As Double
  Dim PtVtxAY As Double
  Dim PtVtxAftAX As Double
  Dim PtVtxAftAY As Double
 
  For i = 0 To LwPOlvtSelset.Count - 1
     Set LwPOlvt = LwPOlvtSelset.Item(i)
         PtVtxOld = LwPOlvt.Coordinates
     Dim m As Integer
         m = UBound(PtVtxOld)    '第一次得到复合线上结点的个数
     '一组数据进行循环
     For k = 2 To m Step 2

        '线的长度小于规定值0.1，则删除这条线
        If LwPOlvt.Length < 0.1 Then LwPOlvt.Delete
       
        If k > m Then GoTo Do_Next
       
        '如果是两点线，则跳出循环
        If (m + 1) / 2 = 2 Then GoTo Do_Next
         '得到线实体的坐标数组
         PtVtxOld = LwPOlvt.Coordinates
         '第一个结点的坐标赋值给新坐标数组
         NewVtxCor(0) = PtVtxOld(0)
         NewVtxCor(1) = PtVtxOld(1)
        
        
         PtVtxAX = PtVtxOld(k - 2): PtVtxAY = PtVtxOld(k - 1)
         '新坐标数组的末尾
         'PtVtxAX = NewVtxCor(UBound(NewVtxCor()) - 1): PtVtxAY = NewVtxCor(UBound(NewVtxCor()))
         PtVtxAftAX = PtVtxOld(k): PtVtxAftAY = PtVtxOld(k + 1)
        
         d = Distance(PtVtxAX, PtVtxAftAX, PtVtxAY, PtVtxAftAY)
        
         '如果两结点距离小于规定值0.1，重新定义新坐标数组的维数
         Dim n As Integer
         If d < 4 Then
            UBound_K = UBound(PtVtxOld) - 2
            ReDim Preserve NewVtxCor(UBound_K)
            For n = k To UBound_K
              NewVtxCor(n) = PtVtxOld(n + 2)
            Next n
         Else
            UBound_K = UBound(PtVtxOld)
            ReDim Preserve NewVtxCor(UBound_K)
            For n = k To UBound(PtVtxOld)
              NewVtxCor(n) = PtVtxOld(n)
            Next n
         End If

         LwPOlvt.Coordinates = NewVtxCor()
         LwPOlvt.Update
         PtVtxOld = LwPOlvt.Coordinates   '更新复合线后再次得到复合线上结点的坐标数组
         m = UBound(PtVtxOld)             '更新复合线后再次得到复合线上结点的个数
        
     Next k

Do_Next:

  Next i
 
 
    '刷新操作
    ThisDrawing.Application.Update

End Sub

'错误
'*************************************************************************
'原因:
'    LwPolyLine.Coordinates只能进行一个结点坐标更新，如果同时变动了很多
'结点坐标，那么程序运行CASS或CAD将出现致命错误。

'——————————————————————————————————
'调试方法1：
'    根据新得到的一组坐标重新绘制LwPolyline，并提取以前那条线的扩展属性
'通过SetXData命令，把获取到的扩展属性赋值给新绘制的LwPolyLine。
'    弊端：
'    由于CAD中对于弧的存储是储存的弧的凸度，对凸度的描述如下图，那么重新
'绘制的时候就把以前的凸度去掉了。如果要重新绘制，就必须把以前有凸度的线条
'的凸度值取出来，然后再重新赋值给新绘制的线，对于这个还没有去研究

'——————————————————————————————————'
'调试方法2：
'    见DelOverlayVertex过程，原理是选取前后两个结点坐标，执行一次，如果
'距离小于规定值，则删除错误的节点，然后执行
'                    LwPolyline.Coordinates=PTs() PTs是新的一组坐标
'                    LwPolyline.Update
'这样两组坐标循环一次，依次类推。

'——————————————————————————————————'
'    本人采取调试方法2，因为调试方法1种对凸度怎么获取？怎么赋值没有了解。
'**************************************************************************
Public Sub DelOverlayVertex_Wrong()
'On Error Resume Next
  '定义选择集
  Dim LwPOlvtSelset As AcadSelectionSet
  Set LwPOlvtSelset = CreateSelectionSet
    
  '建立选择集过滤器
  Dim TypeArray As Variant
  Dim DateArray As Variant
  BuildFilter TypeArray, DateArray, 0, "LWPOLYLINE", 8, "jmd"
 
  LwPOlvtSelset.Select acSelectionSetAll, , , TypeArray, DateArray
 
  Dim LwPOlvt As AcadLWPolyline
  Dim i As Integer  '选择集的个数
  Dim k As Integer  '单个lwpolyline的结点
  '定义新旧结点
  Dim PtVtxOld As Variant
  Dim NewVtxCor() As Double
  ReDim Preserve NewVtxCor(1)
  '定义新坐标数组上维
  Dim UBound_K As Integer
 
  Dim d As Double   '定义结点距离
 
  Dim PtVtxAX As Double
  Dim PtVtxAY As Double
  Dim PtVtxAftAX As Double
  Dim PtVtxAftAY As Double
 
  For i = 0 To LwPOlvtSelset.Count - 1
     Set LwPOlvt = LwPOlvtSelset.Item(i)
         PtVtxOld = LwPOlvt.Coordinates
         '第一个结点的坐标赋值给新坐标数组
         NewVtxCor(0) = PtVtxOld(0)
         NewVtxCor(1) = PtVtxOld(1)
        
     '一组数据进行循环
     For k = 2 To UBound(PtVtxOld) Step 2
         'PtVtxAX = PtVtxOld(k - 2): PtVtxAY = PtVtxOld(k - 1)
         '新坐标数组的末尾
         PtVtxAX = NewVtxCor(UBound(NewVtxCor()) - 1): PtVtxAY = NewVtxCor(UBound(NewVtxCor()))
         PtVtxAftAX = PtVtxOld(k): PtVtxAftAY = PtVtxOld(k + 1)
        
         d = Distance(PtVtxAX, PtVtxAftAX, PtVtxAY, PtVtxAftAY)
        
         '如果两结点距离小于规定值0.1，则不赋值给新坐标数组
         If d > 1 Then
         '确定新坐标上维
           UBound_K = UBound(NewVtxCor()) + 2
           '重新定义新坐标数组上维
           ReDim Preserve NewVtxCor(UBound_K)
          
           NewVtxCor(UBound_K - 1) = PtVtxAftAX
           NewVtxCor(UBound_K) = PtVtxAftAY
        
         End If
     Next k

     '把坐标点导出
     Call aaa(NewVtxCor)
    
     '把新坐标数组赋值给lwpolyline的坐标数组
     LwPOlvt.Coordinates = NewVtxCor()

    'Dim nnn As AcadLWPolyline
    'ThisDrawing.ModelSpace.AddLightWeightPolyline NewVtxCor
   
   
  Next i
 
 
    '刷新操作
    ThisDrawing.Application.Update

End Sub

Public Sub aaa(p1)

'''
'''我将生成的文件保存在c盘，下面的目录是可以随便更改的
'''

Dim jj As Integer

 Open "C:\DelOlvtVtx.txt" For Output As #2
 For jj = 0 To UBound(p1)
 Print #2, p1(jj)
 
 Next jj
 Close #2
End Sub

'创建过滤器的函数
Public Sub BuildFilter(TypeArray, DataArray, ParamArray gCodes())
    Dim fType() As Integer, fData()
    Dim index As Long, i As Long
   
    index = LBound(gCodes) - 1
    For i = LBound(gCodes) To UBound(gCodes) Step 2
        index = index + 1
        ReDim Preserve fType(0 To index)
        ReDim Preserve fData(0 To index)
        fType(index) = CInt(gCodes(i))
        fData(index) = gCodes(i + 1)
    Next
    TypeArray = fType: DataArray = fData
   
End Sub

'创建空间选择集的函数
Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet

    Dim ss As AcadSelectionSet
    On Error Resume Next
    Set ss = ThisDrawing.SelectionSets(ssName)
    If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
    ss.Clear
    Set CreateSelectionSet = ss

End Function

'创建距离函数
Public Function Distance(x0 As Double, x1 As Double, y0 As Double, y1 As Double) As Double
   Dim d As Double
   d = Sqr((x0 - x1) ^ 2 + (y0 - y1) ^ 2)
   Distance = d
End Function