加载中…
个人资料
  • 博客等级:
  • 博客积分:
  • 博客访问:
  • 关注人气:
  • 获赠金笔:0支
  • 赠出金笔:0支
  • 荣誉徽章:
正文 字体大小:

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

(2009-09-04 21:00:32)
标签:

杂谈

分类: 应用
在CASS下根据所选择的实体编码、图层进行闭合操作把代码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 As Integer
    For 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) 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, As Long
   
    index LBound(gCodes) 1
    For 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

0

阅读 收藏 喜欢 打印举报/Report
  

新浪BLOG意见反馈留言板 欢迎批评指正

新浪简介 | About Sina | 广告服务 | 联系我们 | 招聘信息 | 网站律师 | SINA English | 产品答疑

新浪公司 版权所有