CAD VBA过滤器、选择集分享

我看到过这个问题有好几次了，当时只是把代码发给了个人，现在把这些代码贴出来，建立一个专题，加以自己的理解进行说明，希望能对大家在工作中遇到选择集和过滤器问题有所帮助以供大家使用。这种方法建立选择集和过滤器我使用过千百遍，未出现过任何异常。
'——————————————————————————————————
'名称：BuildFilter
'作者：罗简单
'日期：2008-3-11
'功能：创建过滤器
'——————————————————————————————————
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
'——————————————————————————————————
'名称：CreateSelectionSet
'作者：罗简单
'日期：2008-3-11
'功能：创建选择集
'——————————————————————————————————
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

'创建个过程来调用过滤器和选择集
Sub TestBuildFilterAndCteSset()
  '定义过滤器
  Dim pType, pData
  BuildFilter pType, pData, 0, "LWPOLYLINE", 8, "JZD"
  '注意：这里的0与8是通过命令(entget(car(entsel)))获取的对象基本
  '特性，例如：
  '**********************************************************************************
  '((-1 . <图元名: 7ef83b28>) (0 . "LWPOLYLINE") (330 . <图元名:
  '7ef81cc0>) (5 . "425") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 .
  '"JZD") (6 . "Continuous") (100 . "AcDbPolyline") (90 . 2) (70 . 128) (43 . 0.0)
  '(38 . 0.0) (39 . 0.0) (10 92.5011 35.6905) (40 . 0.0) (41 . 0.0) (42 . 0.0) (10
  '208.946 102.652) (40 . 0.0) (41 . 0.0) (42 . 0.0) (210 0.0 0.0 1.0))
  '**********************************************************************************
  '其中比较常用的(0 . "LWPOLYLINE") 表示对象类型；(8 ."JZD")表示对象所在层
  '所以还可以扩展或收缩过滤器，如下
  'BuildFilter pType, pData, 0, "LWPOLYLINE"：建立图上所有的多段线过滤器
  'BuildFilter pType, pData, 0, "LWPOLYLINE", 8, "JZD"：建立图层是JZD的多段线过滤器
  'BuildFilter pType, pData, 0, "LWPOLYLINE", 8, "JZD",62,3：建立图层是JZD、颜色为绿色的多段线过滤器

  '定义选择集
  Dim sset As AcadSelectionSet
  Set sset = CreateSelectionSet

  '根据以上指定的过滤器建立选择集
  sset.Clear
  sset.Select acSelectionSetAll, , , pType, pData
  '这里可以通过Select、SelectAtPoint、SelectByPolygon、SelectOnScreen等方法
  '配合Mode和Point1、Point2建立更加用户化的选择集

End Sub
'当在一个过程中连续使用两个以上的选择集时，需要重新定义选择集，如下：
'创建空间选择集的函数2
Public Function CreateSelectionSet2(Optional ssName As String = "ss2") As AcadSelectionSet
    Dim ss2 As AcadSelectionSet
    On Error Resume Next
    Set ss2 = ThisDrawing.SelectionSets(ssName)
    If Err Then Set ss2 = ThisDrawing.SelectionSets.Add(ssName)
    ss2.Clear
    Set CreateSelectionSet2 = ss2
End Function
'创建个过程来调用过滤器和选择集
Sub TestBuildFilterAndCteSset()
  '定义过滤器
  Dim pType, pData
  BuildFilter pType, pData, 0, "LWPOLYLINE", 8, "JZD"
  '注意：这里的0与8是通过命令(entget(car(entsel)))获取的对象基本
  '特性，例如：
  '**********************************************************************************
  '((-1 . <图元名: 7ef83b28>) (0 . "LWPOLYLINE") (330 . <图元名:
  '7ef81cc0>) (5 . "425") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 .
  '"JZD") (6 . "Continuous") (100 . "AcDbPolyline") (90 . 2) (70 . 128) (43 . 0.0)
  '(38 . 0.0) (39 . 0.0) (10 92.5011 35.6905) (40 . 0.0) (41 . 0.0) (42 . 0.0) (10
  '208.946 102.652) (40 . 0.0) (41 . 0.0) (42 . 0.0) (210 0.0 0.0 1.0))
  '**********************************************************************************
  '其中比较常用的(0 . "LWPOLYLINE") 表示对象类型；(8 ."JZD")表示对象所在层
  '所以还可以扩展或收缩过滤器，如下
  'BuildFilter pType, pData, 0, "LWPOLYLINE"：建立图上所有的多段线过滤器
  'BuildFilter pType, pData, 0, "LWPOLYLINE", 8, "JZD"：建立图层是JZD的多段线过滤器
  'BuildFilter pType, pData, 0, "LWPOLYLINE", 8, "JZD",62,3：建立图层是JZD、颜色为绿色的多段线过滤器

  '定义选择集
  Dim sset As AcadSelectionSet
  Set sset = CreateSelectionSet

  '根据以上指定的过滤器建立选择集
  sset.Clear
  sset.Select acSelectionSetAll, , , pType, pData
  '这里可以通过Select、SelectAtPoint、SelectByPolygon、SelectOnScreen等方法
  '配合Mode和Point1、Point2建立更加用户化的选择集


  '再调用Createselectionset2
  Dim sset2 As AcadSelectionSet
  Set sset2 = CreateSelectionSet2   '注意这里是调用CreateSelectionSet2，依次类推

  sset2.Clear
  sset2.SelectOnScreen pType, pData
End Sub