发布时间 : 星期三 文章CAD实用VBA更新完毕开始阅读7ec12cf91eb91a37f0115c1d
FilterType(2) = 40 FilterData(2) = 5#
sstext.SelectOnScreen FilterType, FilterData End Sub
2.4 Sub Ch4_FilterOrTest()
'下例指定选择 Text 或 Mtext 对象： Dim sstext As AcadSelectionSet Dim FilterType(3) As Integer Dim FilterData(3) As Variant
Set sstext = ThisDrawing.SelectionSets.Add(\FilterType(0) = -4 FilterData(0) = \FilterType(1) = 0
FilterData(1) = \FilterType(2) = 0
FilterData(2) = \FilterType(3) = -4 FilterData(3) = \
sstext.SelectOnScreen FilterType, FilterData End Sub
2.5 Sub Ch4_FilterPolygonWildcard()
'以下代码将选择条件定义为选择所有文本字符串中出现“The”的多行文字。本例还说明了 SelectByPolygon 选择方法的用法： Dim sstext As AcadSelectionSet Dim FilterType(1) As Integer Dim FilterData(1) As Variant
Dim pointsArray(0 To 11) As Double Dim mode As Integer
mode = acSelectionSetWindowPolygon
pointsArray(0) = -12#: pointsArray(1) = -7#: pointsArray(2) = 0 pointsArray(3) = -12#: pointsArray(4) = 10#: pointsArray(5) = 0 pointsArray(6) = 10#: pointsArray(7) = 10#: pointsArray(8) = 0 pointsArray(9) = 10#: pointsArray(10) = -7#: pointsArray(11) = 0 Set sstext = ThisDrawing.SelectionSets.Add(\FilterType(0) = 0
FilterData(0) = \FilterType(1) = 1
FilterData(1) = \
sstext.SelectByPolygon mode, pointsArray, FilterType, FilterData
End Sub
2.6 Sub GetObjInSet()
'请使用名称来引用已知的现有选择集。下例引用名为“SS10”的选择集： Dim selset As AcadSelectionSet
Set selset = ThisDrawing.SelectionSets(\
MsgBox (\selset.Count $ \End Sub
2.7 Sub ListSelectionSets()
'以下代码显示图形中每个选择集的名称，同时列出其包含的对象的类型： Dim selsetCollection As AcadSelectionSets Dim selset As AcadSelectionSet Dim ent As Object Dim i, j As Integer
Set selsetCollection = ThisDrawing.SelectionSets '查找图形中的每个选择集 i = 0
For Each selset In selsetCollection
MsgBox \'现在查找选择集中的每个对象，同时显示其类型 j = 0
For Each ent In selset
MsgBox \ ' $ \ j = j + 1 Next i = i + 1 Next End Sub
3 编辑对象
3.1 Sub Ch4_RenamingLayer()
' 创建图层
Dim layerObj As AcadLayer
Set layerObj = ThisDrawing.Layers.Add(\
' 更改图层的名称
layerObj.Name = \End Sub
3.2 Sub Ch4_CopyCircleObjects()
'本例创建两个 Circle 对象并使用 CopyObjects 方法创建圆的副本。 Dim DOC1 As AcadDocument Dim circleObj1 As AcadCircle Dim circleObj2 As AcadCircle
Dim circleObj1Copy As AcadCircle Dim circleObj2Copy As AcadCircle Dim centerPoint(0 To 2) As Double Dim radius1 As Double Dim radius2 As Double
Dim radius1Copy As Double Dim radius2Copy As Double
Dim objCollection(0 To 1) As Object Dim retObjects As Variant '定义 Circle 对象
centerPoint(0) = 0: centerPoint(1) = 0: centerPoint(2) = 0 radius1 = 5#: radius2 = 7#
radius1Copy = 1#: radius2Copy = 2#
' 创建新图形
Set DOC1 = ThisDrawing.Application.Documents.Add ' 向图形中添加两个圆
Set circleObj1 = DOC1.ModelSpace.AddCircle _ (centerPoint, radius1)
Set circleObj2 = DOC1.ModelSpace.AddCircle _ (centerPoint, radius2) ZoomAll
' 将要复制的对象设置成 '与 CopyObjects 兼容的形式 Set objCollection(0) = circleObj1 Set objCollection(1) = circleObj2
'复制对象并取回新对象（副本） ' 的集合
retObjects = DOC1.CopyObjects(objCollection) ' 获取新创建的对象并 ' 对副本应用新的特性
Set circleObj1Copy = retObjects(0) Set circleObj2Copy = retObjects(1) circleObj1Copy.radius = radius1Copy circleObj1Copy.Color = acRed
circleObj2Copy.radius = radius2Copy circleObj2Copy.Color = acRed ZoomAll End Sub
3.3 Sub Ch4_OffsetPolyline()
' 创建多段线
'本例创建一条优化多段线，然后偏移该多段线。 Dim plineObj As AcadLWPolyline Dim points(0 To 11) As Double points(0) = 1: points(1) = 1 points(2) = 1: points(3) = 2 points(4) = 2: points(5) = 2 points(6) = 3: points(7) = 2 points(8) = 4: points(9) = 4 points(10) = 4: points(11) = 1
Set plineObj = ThisDrawing.ModelSpace. _ AddLightWeightPolyline(points) plineObj.Closed = True ZoomAll
' 偏移多段线
Dim offsetObj As Variant
offsetObj = plineObj.Offset(0.25) ZoomAll End Sub
3.4 Sub Ch4_MirrorPolyline()
' 创建多段线
'本例创建一条优化多段线，然后绕一个轴镜像该多段线。新创建的多段线会着上蓝色。 Dim plineObj As AcadLWPolyline Dim points(0 To 11) As Double points(0) = 1: points(1) = 1 points(2) = 1: points(3) = 2 points(4) = 2: points(5) = 2 points(6) = 3: points(7) = 2 points(8) = 4: points(9) = 4 points(10) = 4: points(11) = 1
Set plineObj = ThisDrawing.ModelSpace. _ AddLightWeightPolyline(points) plineObj.Closed = True ZoomAll