在CASS下根据所选择的实体编码、图层进行闭合操作

heart

把代码copy到代码窗口中即可。
代码如下：
Public Sub ClosedByCode()
'根据实体编码闭合实体
'创建空白选择集
Dim SelSet As AcadSelectionSet
Set SelSet = CreateSelectionSet
'建立选择集过滤器
Dim TypeArray As Variant
Dim DateArray As Variant
BuildFilter TypeArray, DateArray, 0, "LWPOLYLINE", 8,"jmd", 70, "128"
'0 实体类型
'8 实体所在图层
'过滤出所要选择的图块
SelSet.Select acSelectionSetAll, , , TypeArray, DateArray
Dim LwPObj As AcadLWPolyline
Dim I As Integer
For I = 0 To SelSet.Count - 1
Set LwPObj = SelSet.Item(I)
Dim xDataOut As Variant
Dim xTypeOut As Variant
LwPObj.GetXData "", xTypeOut, xDataOut
Select Case xDataOut(1)
Case "141101", "141111", "141121", "141131","141141", "141151", "141161", "141103", "141200","141300", "141400", "141500", "141600", "141700"
'**************************************************************
' Code 名称
' 141101 一般房屋
' 141111 砼房屋
' 141121 砖房屋
' 141131 铁房屋
' 141141 钢房屋
' 141151 木房屋
' 141161 混房屋
' 141103 小比例吃房屋
' 141200 简单房屋
' 141300 建筑房屋
' 141400 破坏房屋
' 141500 棚房
' 141600 架空房屋
' 141700 廊房
'**************************************************************
'执行闭合操作
If LwPObj.Closed = False Then LwPObj.Closed = True
End Select
If UBound(LwPObj.Coordinates) < 4 Then LwPObj.Delete
Next
ThisDrawing.Application.Update '刷新操作
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 ssNameAs 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

tpxjk

说的太好了，也太实用了。

wenxu4660

总是有新的收获！！

wstoky

不太懂！

njyulei

又学习了一招,谢谢

zhewin

不太清楚