CASS或CAD中删除多余结点
2008-04-09 18:37阅读：
有两种方式：
注意：两点线如果距离小于0.1，则删除；且两点线不参加判断。
废话少说，贴代码啊！
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
