CAD vba创建安全选择集(selectionset)、setxdata实例及dxf组码实例

yngsqq

已于 2024-03-05 11:48:44 修改

阅读量1.6k

点赞数 23

分类专栏： CAD VBA 文章标签：开发语言编辑器

于 2023-12-10 01:25:37 首次发布

本文链接：https://blog.csdn.net/yongshiqq/article/details/134902509

版权

CAD VBA 专栏收录该内容

34 篇文章 5 订阅

订阅专栏

我们在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

SelectionSet
使用该方法的对象。

Mode

AcSelect 常数; 仅用于输入

acSelectionSetWindow

acSelectionSetCrossing

acSelectionSetPrevious

acSelectionSetLast

acSelectionSetAll

Point1

Variant[变体] (双精度数组); 仅用于输入; 可选项
指定 Point1 的三维 WCS 坐标，或坐标数组。查看模式定义以正确使用 Point1。

Point2

Variant[变体] (三元素双精度数组); 仅用于输入; 可选项
指定 Point2 的三维 WCS 坐标。查看模式定义以正确使用 Point2。

FilterType

Variant[变体](整数数组); 仅用于输入; 可选项
指定使用的过滤器类型的 DXF 组码。

FilterData

Variant[变体](变体数组); 仅用于输入; 可选项
过滤器的值。

说明

该方法支持过滤机制。

有效的选择模式如下：

Window

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

Crossing

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

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

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，故插播一个函数：

函数示例
本示例使用 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