我们在VBA 创建选择集时 ，安全起见需要判断选择集名是否重复，如下代码：

Sub 创建安全选择集() On Error Resume Next Dim sel As AcadSelectionSet If Not IsNull(ThisDrawing.SelectionSets.Item("mysel")) Then Set sel = ThisDrawing.SelectionSets.Item("mysel") sel.Delete ''如果图中有名为"mysel"的选择集，那么把这个选择集放入sel中，然后删除这个选择集 End If ''如果图中没有"mysel"，那么新建一个名为"mysel"的选择集，赋给sel这个对象 Set sel = ThisDrawing.SelectionSets.Add("mysel") sel.Select acSelectionSetAll End Sub 

或者这样：

讯享网 ''创建选择集前先判断有没有存在的选择集 Do While ThisDrawing.SelectionSets.Count > 0 ThisDrawing.SelectionSets.Item(0).Delete Loop

为了方便使用选择集，我们需要定义个创建选择集函数，需要时直接调用即可。

Public Function creatsel() As AcadSelectionSet On Error Resume Next Dim sel As AcadSelectionSet If Not IsNull(ThisDrawing.SelectionSets.Item("mysel")) Then Set creatsel = ThisDrawing.SelectionSets.Item("mysel") creatsel.Delete ''如果图中有名为"mysel"的选择集，那么把这个选择集放入sel中，然后删除这个选择集 End If ''如果图中没有"mysel"，那么新建一个名为"mysel"的选择集，赋给sel这个对象 Set creatsel = ThisDrawing.SelectionSets.Add("mysel") End Function Sub a() Set sel = creatsel() sel.Select acSelectionSetAll MsgBox sel.Count End Sub

此代码在同一程序内只能创建一个选择集，如果程序需要同时创建多个选择集，则需要重新写函数，代码如下：

讯享网Public Function creatsel(ByVal selname As String) As AcadSelectionSet On Error Resume Next For i = 0 To ThisDrawing.SelectionSets.Count - 1 Set sel = ThisDrawing.SelectionSets.Item(i) If StrComp(sel.Name, selname, 1) = 0 Then sel.Delete Exit For End If Next i Set creatsel = ThisDrawing.SelectionSets.Add(selname) End Function Sub a() Dim sel As AcadSelectionSet Set sel = creatsel("mysel") sel.Select acSelectionSetAll MsgBox sel.Count End Sub 

 
讯享网

object.Select Mode[, Point1][, Point2][, FilterType][, FilterData]

Object

Mode

AcSelect 常数; 仅用于输入

acSelectionSetWindow

acSelectionSetCrossing

acSelectionSetPrevious

acSelectionSetLast

acSelectionSetAll

Point1

Point2

FilterType

FilterData

说明

该方法支持过滤机制。

有效的选择模式如下：

Window

选择完全在矩形区域内的所有对象，矩形对角由 Point1 和 Point2 定义。

Crossing

选择在矩形区域内和与矩形区域相交的对象，矩形对角由 Point1 和 Point2 定义。

Previous

选择最近的选择集。如果用户在图纸空间和模型空间之间进行切换并试图使用选择集，该模式将被忽略。

Last

选择最近生成的可见对象。

All

选择所有对象。

有关更多的选择模式选项，可参见 SelectByPolygon, SelectAtPoint, 和 SelectOnScreen 方法。

 上面函数中有个strcomp函数，即判断两个字符串是否相等。在CAD VBA中，不允许两个选择集名字相同，同一个字母大小写视为相同字符，而strcomp函数就是为此量身定做对比字符串的，

如下：

StrComp（） 函数示例 如果第三个参数值为 1(即vbTextCompare)，字符串是以文本比较的方式进行比较（注意：大小写字母视为一样）； 如果第三个参数值为 0 或是缺省，则以二进制比较的方式进行比较。 sub a() Dim a, b, c a = "ABCD": b = "abcd" ' 定义变量。 c = StrComp(MyStr1, MyStr2, 1) ' 返回 0。 c = StrComp(MyStr1, MyStr2, 0) ' 返回 -1。 c = StrComp(MyStr2, MyStr1) ' 返回 1。 End Sub 

另附选择集常用dxf组码：

DXF 码                                       过滤器类型 
0 (or DxfCode.Start)                   对象类型（字符串） 例如 直线、圆、圆弧等等。
2 (or DxfCode.BlockName)        块名（字符串） 一个插入引用的块名
 
8 or (DxfCode.LayerName)        图层名（字符串）例如 Layer 0
60 (DxfCode.Visibility)               可见性（整数）使用 0 = 可见，1 = 不可见。
 
62 (or DxfCode.Color)                颜色编号（整数）范围 0 到 256 内的数字索引值。
                                          零表示 BYBLOCK。256 表示 BYLAYER。负值表示图层被关闭。
67                          模型/图纸空间标识符（整数）使用 0 或省略 = 模型空间，1 = 图纸空间。

另：有写代码这样写

ReDim fType(0): ReDim fData(0)
fType(0) = 0: fData(0) = "Text,MText"  '逗号表示或的关系
Set sel = ActiveDocument.SelectionSets.Add(Mysel) 

可以将多个名称写入同一个fdata中，尚未验证是否可行，逗号是否可用中文状态下逗号，有待验证。

 当选择条件比较多时，还有这样写代码的方式可借鉴：

 i = 0
    fType(i) = -4: fData(i) = "<or"
    i = i + 1: fType(i) = -4: fData(i) = "<and"
    i = i + 1: fType(i) = 0: fData(i) = "Text"
    i = i + 1: fType(i) = 1: fData(i) = "*" & txtFindLine & "*"
    i = i + 1: fType(i) = -4: fData(i) = "and>"
    
    i = i + 1: fType(i) = -4: fData(i) = "<and"
    i = i + 1: fType(i) = 0: fData(i) = "Text"
    i = i + 1: fType(i) = 1: fData(i) = "*" & UCase(txtFindLine) & "*"
    i = i + 1: fType(i) = -4: fData(i) = "and>"
    
    i = i + 1: fType(i) = -4: fData(i) = "or>" 

i=i+1这个操作，可避免重复输入代码，直接复制稍作修改即可。

fdata内容还可有*" & txtFindLine & "*这种操作？（上面代码意思为：选择文字，图元文字内容包含特定字符串，或包含这些特定字符串的大写字母，即可选中）。不知是否能识别，也有待验证。

因上面代码出现UCase，故插播一个函数：

Dim LowerCase, UpperCase
LowerCase = "Hello World 1234"    ' 要输送的字符串。
UpperCase = UCase(LowerCase)    ' 返回 "HELLO WORLD 1234"。

 另附添加属性set xdata的一些实例代码，可供学习参考：

讯享网 Dim a() As String Dim fType(0) As Integer, fData(0) As Variant Dim sset As AcadSelectionSet, elem As AcadEntity Dim bType As Variant, bData As Variant '用于获取拓展数据 Dim Array1 As Variant '用于获取属性 Dim xh As Integer Public LTP1(0 To 2) As Double '查找范围左下角点，线号查找排除 Public LTP2(0 To 2) As Double '查找范围右上角点，线号查找排除 Public Type GGBJ '变更标记块 GGCode As String GGDesc As String GGDate As String End Type '提取范围变更标记 40 iniTmp = ReadIniFile("C:\Users\Public\XSCADCAPP.ini", "提取图纸", "提取范围") 41 If iniTmp <> "" Then 42 Nos = Split(iniTmp, ",", , vbTextCompare) 43 If UBound(Nos) = 4 Then 44 LTP1(0) = Val(Nos(0)): LTP1(1) = Val(Nos(1)) 45 LTP2(0) = Val(Nos(2)): LTP2(1) = Val(Nos(3)) 46 End If 47 End If '提取范围内的标记 48 Set sset = acadApp.ActiveDocument.SelectionSets.Add(MyNow) 49 fType(0) = 1001: fData(0) = "变更标记块" 50 If LTP1(0) = 0 And LTP1(1) = 0 Then 51 sset.Select acSelectionSetAll, , , fType, fData '已加：可见过滤 5-acSelectionSetAll 全图不需要范围 52 Else 53 acadApp.ZoomWindow LTP1, LTP2 '需要先缩放一下 54 sset.Select acSelectionSetWindow, LTP1, LTP2, fType, fData '已加：可见过滤 0-acSelectionSetWindow 55 acadApp.ZoomPrevious '还原成之前的 视图 56 End If 57 ReDim GGBJArr(1 To sset.Count) As GGBJ 58 For Each elem In sset ' elem.GetXData "变更标记块", bType, bData ' If IsEmpty(bData) Then '有拓展数据 ' If UBound(bData) > 2 Then bData(2) = "给拓展数据赋的值" ' End If 59 xh = 1 60 If elem.HasAttributes Then '获取属性 61 Array1 = elem.GetAttributes 62 For i = 0 To UBound(Array1) ' '读属性 63 Select Case Array1(i).TagString Case "序号" 64 GGBJArr(xh).GGCode = Array1(i).TextString 65 Case "变更说明" 66 GGBJArr(xh).GGDesc = Array1(i).TextString 67 Case "变更日期" 68 GGBJArr(xh).GGDate = Array1(i).TextString 69 End Select 70 Next 71 End If 72 xh = xh + 1 73 Next 74 sset.Delete