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 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