CAD开发——AcadSelectionSet 选择集

墨家前任巨子

已于 2023-11-12 22:00:58 修改

阅读量3.1k

点赞数 14

分类专栏： CAD学习文章标签： 1024程序员节

于 2022-10-24 10:40:12 首次发布

本文链接：https://blog.csdn.net/qq_39728950/article/details/127487393

版权

CAD学习专栏收录该内容

9 篇文章 2 订阅

订阅专栏

1. 定义一个永不重复的时间变量

Private Declare Sub GetSystemTime Lib "kernel32" (lpSystemTime As SYSTEMTIME) ''------强制退出AutoCAD当前运行的命令
''------------
Private Type SYSTEMTIME
 wYear As Integer
 wMonth As Integer
 wDayOfWeek As Integer
 wDay As Integer
 wHour As Integer
 wMinute As Integer
 wSecond As Integer
 wMilliseconds As Integer
End Type


Public Function MyNow() As String
Dim st As SYSTEMTIME
GetSystemTime st
MyNow = "a" & st.wDay & st.wHour & st.wMinute & st.wSecond & st.wMilliseconds
End Function

vba中

Public Function MyNow() As String
    MyNow = Format(Now, "HH-MM-SS")
End Function

2. 创建一个选择集变量

Dim sset As AcadSelectionSet
Set sset = acadApp.ActiveDocument.SelectionSets.Add(MyNow)

3. 选择集选择对象

① selectOnscreen 提示用户从屏幕上拾取对象。

Dim fType(0) As Integer, fData(0) As Variant
Dim sset As AcadSelectionSet, elem As AcadEntity
Set sset = acadApp.ActiveDocument.SelectionSets.Add(MyNow)
fType(0) = 0: fData(0) = "Insert"
'fData(0) = "Text,MText"
Err.Clear
acadApp.ActiveDocument.Utility.Prompt vbCr & "请选择预设属性随层的护套图块对象："
sset.SelectOnScreen fType, fData
If sset.Count < 1 Then MsgBox "选择对象中没有发现护套图块.", vbOKOnly + vbInformation, "选择护套图块提示": sset.Delete: Exit Sub

For Each elem In sset

next

sset.delete

② sset.Select

过滤模式有以下几种：

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

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

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

Last（acselectionsetlast）选择最近生成的可见对象。

All（acselectionsetall）选择所有对象。

由于选取选择集，受限制于窗口(全图不限制)，需要缩放图纸

acadApp.ZoomAll '用于缩放当前视图，显示整个图形。
acadApp.ZoomWindow MinP, MaxP '由用户在绘图区域指定窗口缩放当前视图。
acadApp.ZoomExtents '全图缩放将当前视图缩放到图形界限。
acadApp.ZoomPrevious '恢复到上一个视图
acadApp.ActiveDocument.Application.ZoomCenter txtInp, 150 通过指定缩放中心点和比例缩放当前视图。

例子：

    Dim Nos() 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

常用的DXF组码一般有：

0 ：图元类型

1 ：图元的主文字值(似乎多行文字不起作用)

60 ：可见性 0 = 可见 1= 不可见

1001 : 扩展数据的注册应用程序名（最多可以包含 31 个字节的 ASCII 字符串）

1000：扩展数据中的 ASCII 字符串（最多可以包含 255 个字节） 1070：扩展数据 16 位有符号整数

1071：扩展数据 32位有符号整数

1040：双精度浮点数

CAD DXF组码 - 360文档中心

对于组码0：图元类型一般有这些

Insert 图块

LWPolyline 多段线

Text ,MText 单行文本，多行文本(,表示或的关系)

Hatch 图案填充，由直线图案组成的区域填充

Dimension 标注

ATTDEF 属性

acadApp.ZoomCenter center, 4000  '需要缩放一下，保证图元能够被拾取到
sset.Select acSelectionSetWindow, P1, P2, fType, fData

CADVBA选择集研究笔记CADVBA选择集研究笔记http://www.360doc.com/content/21/1030/09/51100410_1001897889.shtml

一些实例

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

 i = 2
    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>"

Cad 对象

dim txtObj as acadText .EntityType = 21 OR .EntityType = 32

dim elem as AcadEntity

dim Blk as AcadBlockReference