CAD vba创建安全选择集(selectionset)实例及dxf组码实例
我们在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
Dim sel As AcadSelectionSet
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()
Set sel = creatsel("mysel")
sel.Select acSelectionSetAll
MsgBox sel.Count
End Sub
上面函数中有个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) = "
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) = "
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，故插播一个函数：
函数示例
本示例使用 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