CAD实用VBA

1 创建对象

1.1 Sub Ch2_FindFirstEntity()

'本例返回模型空间中的第一个图元 On Error Resume Next Dim entity As AcadEntity

If ThisDrawing.ModelSpace.count <> 0 Then Set entity = ThisDrawing.ModelSpace.Item(0) MsgBox entity.ObjectName + _

\否则 MsgBox \ End If End Sub

1.2 Sub Ch2_IterateLayer()

'本例遍历集合，并显示集合中所有图层的名称： On Error Resume Next Dim I As Integer Dim msg As String msg = \

For I = 0 To ThisDrawing.Layers.count - 1

msg = msg + ThisDrawing.Layers.Item(I).Name + vbCrLf Next

MsgBox msg End Sub

1.3 Sub Ch2_FindLayer()

'使用 Item 方法查找名为 MyLayer 的图层 On Error Resume Next

Dim ABCLayer As AcadLayer

Set ABCLayer = ThisDrawing.Layers(\If Err <> 0 Then

MsgBox \ 'MyLayer' does not exist.\ End If End Sub

1.4 Sub Ch2_CreateSplineUsingTypedArray()

'本例使用 CreateTypedArray 方法 '在模型空间中创建样条曲线对象。 Dim splineObj As AcadSpline Dim startTan As Variant Dim endTan As Variant Dim fitPoints As Variant

Dim utilObj As Object ' 后期绑定 Utility 对象 Set utilObj = ThisDrawing.Utility

'定义 Spline 对象

utilObj.CreateTypedArray _ startTan, vbDouble, 0.5, 0.5, 0 utilObj.CreateTypedArray _ endTan, vbDouble, 0.5, 0.5, 0 utilObj.CreateTypedArray _

fitPoints, vbDouble, 0, 0, 0, 5, 5, 0, 10, 0, 0

Set splineObj = ThisDrawing.ModelSpace.AddSpline _ (fitPoints, startTan, endTan) ' 放大新创建的样条曲线 ZoomAll End Sub

1.5 Sub Ch4_AddLightWeightPolyline()

Dim plineObj As AcadLWPolyline Dim points(0 To 5) As Double ' 定义二维多段线的点 points(0) = 2: points(1) = 4 points(2) = 4: points(3) = 2 points(4) = 6: points(5) = 4

'在模型空间中创建一个优化多段线对象 Set plineObj = ThisDrawing.ModelSpace. _ AddLightWeightPolyline(points) ThisDrawing.Application.ZoomAll End Sub

1.6 Sub Ch4_AddLightWeightPolyline()

'下例使用坐标 (0,0,0)、(5,0,0)、(5,8,0) 和 (0,8,0) 在模型空间中创建四边形实体。 Dim plineObj As AcadLWPolyline Dim points(0 To 5) As Double

' 定义二维多段线的点 points(0) = 2: points(1) = 4 points(2) = 4: points(3) = 2 points(4) = 6: points(5) = 4

'在模型空间中创建一个优化多段线对象 Set plineObj = ThisDrawing.ModelSpace. _ AddLightWeightPolyline(points) ThisDrawing.Application.ZoomAll End Sub

1.7 Sub Ch4_CreateHatch()

'本例在模型空间中创建关联的图案填充。创建图案填充后，可以修改与图案填充关联的圆的大小。图案填充将自动改变以匹配圆的当前大小。 Dim hatchObj As AcadHatch Dim patternName As String Dim PatternType As Long

Dim bAssociativity As Boolean

' 定义图案填充

patternName = \PatternType = 0 bAssociativity = True

'创建关联的 Hatch 对象

Set hatchObj = ThisDrawing.ModelSpace.AddHatch _ (PatternType, patternName, bAssociativity) '创建图案填充的外边界。（一个圆） Dim outerLoop(0 To 0) As AcadEntity Dim center(0 To 2) As Double Dim radius As Double

center(0) = 3: center(1) = 3: center(2) = 0 radius = 1

Set outerLoop(0) = ThisDrawing.ModelSpace. _ AddCircle(center, radius)

'向 Hatch 对象附加外边界， ' 并显示图案填充

hatchObj.AppendOuterLoop (outerLoop) hatchObj.Evaluate

ThisDrawing.Regen True End Sub

2 使用选择集

2.1 Sub Ch4_FilterMtext()

'以下代码提示用户选择要包含在选择集中的对象，但仅当选择的对象是 Circle 时才将其添加到选择集中：

Dim sstext As AcadSelectionSet Dim FilterType(0) As Integer Dim FilterData(0) As Variant

Set sstext = ThisDrawing.SelectionSets.Add(\FilterType(0) = 0 ' 表示过滤器是对象类型

FilterData(0) = \表示对象类型是“Circle” sstext.SelectOnScreen FilterType, FilterData End Sub

2.2 Sub Ch4_FilterBlueCircleOnLayer0()

'以下代码指定了两个标准：对象必须是圆，并且必须在图层 0 上。代码将 FilterType 和 FilterData 声明为两个元素的数组，并将每个条件指定给一个元素： Dim sstext As AcadSelectionSet Dim FilterType(1) As Integer Dim FilterData(1) As Variant

Set sstext = ThisDrawing.SelectionSets.Add(\FilterType(0) = 0

FilterData(0) = \FilterType(1) = 8 FilterData(1) = \

sstext.SelectOnScreen FilterType, FilterData End Sub

2.3 Sub Ch4_FilterRelational()

'以下代码指定选择半径大于或等于 5.0 的圆： Dim sstext As AcadSelectionSet Dim FilterType(2) As Integer Dim FilterData(2) As Variant

Set sstext = ThisDrawing.SelectionSets.Add(\FilterType(0) = 0

FilterData(0) = \FilterType(1) = -4 FilterData(1) = \

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

' 定义镜像轴

Dim point1(0 To 2) As Double Dim point2(0 To 2) As Double

point1(0) = 0: point1(1) = 4.25: point1(2) = 0 point2(0) = 4: point2(1) = 4.25: point2(2) = 0 ' 镜像多段线

Dim mirrorObj As AcadLWPolyline

Set mirrorObj = plineObj.Mirror(point1, point2) Dim col As New AcadAcCmColor Call col.SetRGB(125, 175, 235) mirrorObj.TrueColor = col ZoomAll End Sub

3.5 Sub Ch4_ArrayingACircle()

'本例创建一个圆，然后对圆执行环形阵列操作。这个过程将围绕基点 (4,4,0)，在 180 度内创建四个圆。 ' 创建圆

Dim circleObj As AcadCircle Dim center(0 To 2) As Double Dim radius As Double

center(0) = 2#: center(1) = 2#: center(2) = 0# radius = 1

Set circleObj = ThisDrawing.ModelSpace. _ AddCircle(center, radius) ZoomAll

' 定义环形阵列

Dim noOfObjects As Integer Dim angleToFill As Double Dim basePnt(0 To 2) As Double noOfObjects = 4

angleToFill = 3.14 ' 180 度

basePnt(0) = 4#: basePnt(1) = 4#: basePnt(2) = 0# '下例通过绕点 (3,3,0) 旋转和 ' 复制对象而创建四个 ' 对象副本。

Dim retObj As Variant

retObj = circleObj.ArrayPolar _

(noOfObjects, angleToFill, basePnt) ZoomAll End Sub

3.6 Sub Ch4_ArrayRectangularExample()

' 创建圆

'本例创建一个圆，然后对该圆执行矩形阵列操作，创建 5 行 5 列的圆。 Dim circleObj As AcadCircle Dim center(0 To 2) As Double Dim radius As Double

center(0) = 2#: center(1) = 2#: center(2) = 0# radius = 0.5

Set circleObj = ThisDrawing.ModelSpace. _ AddCircle(center, radius) ZoomAll

' 定义矩形阵列

Dim numberOfRows As Long Dim numberOfColumns As Long Dim numberOfLevels As Long Dim distanceBwtnRows As Double Dim distanceBwtnColumns As Double Dim distanceBwtnLevels As Double numberOfRows = 5 numberOfColumns = 5 numberOfLevels = 2 distanceBwtnRows = 1 distanceBwtnColumns = 1 distanceBwtnLevels = 1 ' 创建对象的阵列 Dim retObj As Variant

retObj = circleObj.ArrayRectangular _

(numberOfRows, numberOfColumns, numberOfLevels, _

distanceBwtnRows, distanceBwtnColumns, distanceBwtnLevels) ZoomAll End Sub

3.7 Sub Ch4_MoveCircle()

'本例创建一个圆，然后将此圆沿着 X 轴移动两个单位。 ' 创建圆

Dim circleObj As AcadCircle Dim center(0 To 2) As Double Dim radius As Double

center(0) = 2#: center(1) = 2#: center(2) = 0# radius = 0.5

Set circleObj = ThisDrawing.ModelSpace. _

AddCircle(center, radius) ZoomAll

'定义组成移动矢量的点。 '移动矢量将圆沿 x 轴移动 ' 两个单位。

Dim point1(0 To 2) As Double Dim point2(0 To 2) As Double

point1(0) = 0: point1(1) = 0: point1(2) = 0 point2(0) = 2: point2(1) = 0: point2(2) = 0 ' 移动圆

circleObj.Move point1, point2 circleObj.Update End Sub

3.8 Sub Ch4_RotatePolyline()

' 创建多段线

'本例创建一条闭合的优化多段线，然后将该多段线绕基点 (4,4.25,0) 旋转 45 度。 Dim plineObj As AcadLWPolyline Dim points(0 To 11) As Double points(0) = 1: points(1) = 2 points(2) = 1: points(3) = 3 points(4) = 2: points(5) = 3 points(6) = 3: points(7) = 3 points(8) = 4: points(9) = 4 points(10) = 4: points(11) = 2

Set plineObj = ThisDrawing.ModelSpace. _ AddLightWeightPolyline(points) plineObj.Closed = True ZoomAll

'定义绕点 (4,4.25,0) 旋转 ' 45 度

Dim basePoint(0 To 2) As Double Dim rotationAngle As Double

basePoint(0) = 4: basePoint(1) = 4.25: basePoint(2) = 0 rotationAngle = 0.7853981 ' 45 degrees ' 旋转多段线

plineObj.Rotate basePoint, rotationAngle plineObj.Update End Sub

3.9 Sub Ch4_DeletePolyline()

'本例创建一条优化多段线，然后将其删除。 ' 创建多段线

Dim lwpolyObj As AcadLWPolyline Dim vertices(0 To 5) As Double vertices(0) = 2: vertices(1) = 4 vertices(2) = 4: vertices(3) = 2 vertices(4) = 6: vertices(5) = 4

Set lwpolyObj = ThisDrawing.ModelSpace. _ AddLightWeightPolyline(vertices) ZoomAll ' 删除多段线 lwpolyObj.Delete

ThisDrawing.Regen acActiveViewport End Sub

3.10 Sub Ch4_ScalePolyline()

'本例创建一条闭合的优化多段线，然后以 0.5 的缩放比例调整该多段线。 ' 创建多段线

Dim plineObj As AcadLWPolyline Dim points(0 To 11) As Double points(0) = 1: points(1) = 2 points(2) = 1: points(3) = 3 points(4) = 2: points(5) = 3 points(6) = 3: points(7) = 3 points(8) = 4: points(9) = 4 points(10) = 4: points(11) = 2

Set plineObj = ThisDrawing.ModelSpace. _ AddLightWeightPolyline(points) plineObj.Closed = True ZoomAll

' 定义缩放

Dim basePoint(0 To 2) As Double Dim scalefactor As Double

basePoint(0) = 4: basePoint(1) = 4.25: basePoint(2) = 0 scalefactor = 0.5 ' 缩放多段线

plineObj.ScaleEntity basePoint, scalefactor plineObj.Update End Sub

3.11 Sub Ch4_LengthenLine()

'本例创建一条直线，然后修改其端点拉长该直线。 ' 定义和创建直线 Dim lineObj As AcadLine

Dim startPoint(0 To 2) As Double Dim endPoint(0 To 2) As Double startPoint(0) = 0 startPoint(1) = 0 startPoint(2) = 0 endPoint(0) = 1 endPoint(1) = 1 endPoint(2) = 1

Set lineObj = ThisDrawing.ModelSpace. _ AddLine(startPoint, endPoint) lineObj.Update

'将端点更改为 4,4,4 ' 拉长直线 endPoint(0) = 4 endPoint(1) = 4 endPoint(2) = 4

lineObj.endPoint = endPoint lineObj.Update End Sub

3.12 Sub Ch4_ExplodePolyline()

'本例创建一个优化多段线对象，然后将多段线分解成多个对象。接着遍历产生的对象，显示含有每个对象名称的消息框，并显示分解对象在列表中的索引。 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.SetBulge 3, -0.5 plineObj.Update ' 分解多段线

Dim explodedObjects As Variant explodedObjects = plineObj.Explode ' 遍历分解的对象 ' 并以消息框来显示 ' 每个对象的类型 Dim I As Integer

For I = 0 To UBound(explodedObjects) explodedObjects(I).Update

MsgBox \explodedObjects(I).ObjectName explodedObjects(I).Update Next End Sub

3.13 Sub Ch4_EditPolyline()

'本例创建一条优化多段线，然后向多段线的第三段添加凸度，向多段线附加顶点，修改最后一段的宽度，最后闭合多段线。 Dim plineObj As AcadLWPolyline Dim points(0 To 9) 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 ' 创建优化多段线对象

Set plineObj = ThisDrawing.ModelSpace. _ AddLightWeightPolyline(points) ' 向线段 3 添加凸度 plineObj.SetBulge 3, -0.5

' 定义新的顶点

Dim newVertex(0 To 1) As Double newVertex(0) = 4: newVertex(1) = 1 ' 向多段线添加顶点

plineObj.AddVertex 5, newVertex ' 设置新线段的宽度

plineObj.SetWidth 4, 0.1, 0.5 ' 闭合多段线

plineObj.Closed = True plineObj.Update

End Sub

3.14 Sub Ch4_AppendInnerLoopToHatch()

'本例创建一个关联的图案填充，然后创建一个圆并将该圆作为内部环附加到图案填充。 Dim hatchObj As AcadHatch Dim patternName As String Dim PatternType As Long

Dim bAssociativity As Boolean

' 定义和创建图案填充 patternName = \PatternType = 0 bAssociativity = True

Set hatchObj = ThisDrawing.ModelSpace. _

AddHatch(PatternType, patternName, bAssociativity) ' 创建图案填充的外部环

Dim outerLoop(0 To 1) As AcadEntity Dim center(0 To 2) As Double Dim radius As Double Dim startAngle As Double Dim endAngle As Double

center(0) = 5: center(1) = 3: center(2) = 0 radius = 3 startAngle = 0

endAngle = 3.141592

Set outerLoop(0) = ThisDrawing.ModelSpace. _ AddArc(center, radius, startAngle, endAngle) Set outerLoop(1) = ThisDrawing.ModelSpace. _

AddLine(outerLoop(0).startPoint, outerLoop(0).endPoint) '将外部环附加到 Hatch 对象

hatchObj.AppendOuterLoop (outerLoop) '创建一个圆作为图案填充的内部环 Dim innerLoop(0) As AcadEntity

center(0) = 5: center(1) = 4.5: center(2) = 0 radius = 1

Set innerLoop(0) = ThisDrawing.ModelSpace. _ AddCircle(center, radius)

'将圆作为内部环附加到图案填充

hatchObj.AppendInnerLoop (innerLoop) ' 计算并显示图案填充 hatchObj.Evaluate

ThisDrawing.Regen True End Sub

3.15 Sub Ch4_ChangeHatchPatternSpace()

'本例创建一个图案填充，然后将该图案填充的当前图案间距增加 2。 Dim hatchObj As AcadHatch Dim patternName As String Dim PatternType As Long

Dim bAssociativity As Boolean ' 定义图案填充

patternName = \PatternType = 0 bAssociativity = True

'创建关联的 Hatch 对象

Set hatchObj = ThisDrawing.ModelSpace. _

AddHatch(PatternType, patternName, bAssociativity) ' 创建图案填充的外部环

Dim outerLoop(0 To 0) As AcadEntity Dim center(0 To 2) As Double Dim radius As Double center(0) = 5 center(1) = 3 center(2) = 0 radius = 3

Set outerLoop(0) = ThisDrawing.ModelSpace. _ AddCircle(center, radius)

hatchObj.AppendOuterLoop (outerLoop) hatchObj.Evaluate

'向当前间距加 2，以更改填充图案 ' 的间距

hatchObj.patternSpace = hatchObj.patternSpace + 2 hatchObj.Evaluate

ThisDrawing.Regen True End Sub

4 使用图层

4.1 Sub Ch4_IteratingLayers()

'以下代码遍历 Layers 集合，以合并图形中所有图层的名称，然后将这些名称显示在消息框中。

Dim layerNames As String Dim entry As AcadLayer

layerNames = \

For Each entry In ThisDrawing.Layers

layerNames = layerNames + entry.Name + vbCrLf Next

MsgBox \vbCrLf + layerNames End Sub

4.2 Sub Ch4_NewLayer()

'以下代码创建一个圆和一个新图层。新的图层指定使用红色。圆被指定到该图层，然后其颜色也相应改变。 ' 创建圆

Dim circleObj As AcadCircle Dim center(0 To 2) As Double Dim radius As Double

center(0) = 2: center(1) = 2: center(2) = 0 radius = 1

Set circleObj = ThisDrawing.ModelSpace. _ AddCircle(center, radius) ' 创建颜色对象

Dim col As New AcadAcCmColor

col.ColorMethod = AutoCAD.acColorMethodForeground ' 设置图层的颜色

Dim layColor As AcadAcCmColor Set layColor =

AcadApplication.GetInterfaceObject(\Call layColor.SetRGB(122, 199, 25)

ThisDrawing.ActiveLayer.TrueColor = layColor

col.ColorMethod = AutoCAD.acColorMethodByLayer '将圆的颜色指定为“BYLAYER” '以便圆自动拾取所在图层的 ' 颜色

circleObj.Color = acByLayer circleObj.Update End Sub

4.3 Sub Ch4_LayerInvisible()

'本例创建一个新的图层并在该图层上添加一个圆，然后关闭图层使圆不可见。 ' 创建圆

Dim circleObj As AcadCircle Dim center(0 To 2) As Double

Dim radius As Double

center(0) = 2: center(1) = 2: center(2) = 0 radius = 1

Set circleObj = ThisDrawing.ModelSpace. _ AddCircle(center, radius)

' 创建新图层“ABC”

Dim layerObj As AcadLayer

Set layerObj = ThisDrawing.Layers.Add(\'将圆指定到“ABC”图层 circleObj.Layer = \circleObj.Update ' 关闭图层“ABC”

layerObj.LayerOn = False

ThisDrawing.Regen acActiveViewport End Sub

4.4 Sub Ch4_LayerFreeze()

'本例创建一个称为“ABC”的新图层，然后冻结该图层。 ' 创建新图层“ABC”

Dim layerObj As AcadLayer

Set layerObj = ThisDrawing.Layers.Add(\ ' 冻结图层“ABC” layerObj.Freeze = True End Sub

4.5 Sub Ch4_LayerLock()

'本例创建一个称为“ABC”的新图层，然后锁定该图层。 ' 创建新图层“ABC”

Dim layerObj As AcadLayer

Set layerObj = ThisDrawing.Layers.Add(\ ' 锁定图层“ABC” layerObj.Lock = True End Sub

5 使用线型

5.1 Sub Ch4_LoadLinetype()

'本例试图从 acad.lin 文件中加载线型“CENTER”。如果该线型已存在或者文件不存在，则显

示相关消息。

On Error GoTo ERRORHANDLER Dim linetypeName As String linetypeName = \

'从 acad.lin 文件加载“CENTER”线型

ThisDrawing.Linetypes.Load linetypeName, \ Exit Sub

ERRORHANDLER:

MsgBox Err.Description End Sub

5.2 Sub Ch4_ChangeLinetypeScale()

'更改一个圆的线型比例 ' 保存当前的线型

Set currLineType = ThisDrawing.ActiveLinetype '将活动线型更改为 Border，使比例的更改 ' 可见。

'首先查看 Border 线型是否已加载 On Error Resume Next ' 打开错误捕获

ThisDrawing.ActiveLinetype = ThisDrawing.Linetypes.Item(\If Err.Number = -2145386476 Then

'错误指出尚未加载线型，因此加载它。

ThisDrawing.Linetypes.Load \ThisDrawing.ActiveLinetype = _

ThisDrawing.Linetypes.Item(\ End If

On Error GoTo 0 ' 关闭错误捕获 '在模型空间中创建 Circle 对象 Dim center(0 To 2) As Double Dim radius As Double

Dim circleObj As AcadCircle center(0) = 2 center(1) = 2 center(2) = 0 radius = 4

Set circleObj = ThisDrawing.ModelSpace.AddCircle(center, radius) circleObj.Update

MsgBox (\'将圆的线型比例设为 3 circleObj.LinetypeScale = 3# circleObj.Update

MsgBox (\ ' 恢复原始活动线型

ThisDrawing.ActiveLinetype = currLineType End Sub

5.3 Sub Ch4_MoveObjectNewLayer()

'本例在活动图层上创建一个圆，然后创建一个称为“ABC”的新图层。接着将圆移动到新图层上。

' 创建圆

Dim circleObj As AcadCircle Dim center(0 To 2) As Double Dim radius As Double

center(0) = 2: center(1) = 2: center(2) = 0 radius = 1

Set circleObj = ThisDrawing.ModelSpace. _ AddCircle(center, radius) ' 创建新图层“ABC”

Dim layerObj As AcadLayer

Set layerObj = ThisDrawing.Layers.Add(\'将圆指定到“ABC”图层 circleObj.Layer = \circleObj.Update End Sub

5.4 Sub Ch4_ColorCircle()

'本例创建一个圆，然后将其着色为蓝色。 Dim color As AcadAcCmColor Set color = _

AcadApplication.GetInterfaceObject(\Call color.SetRGB(80, 100, 244) Dim circleObj As AcadCircle

Dim centerPoint(0 To 2) As Double Dim radius As Double

centerPoint(0) = 0#: centerPoint(1) = 0#: centerPoint(2) = 0# radius = 5# Set circleObj = _

ThisDrawing.ModelSpace.AddCircle(centerPoint, radius) circleObj.TrueColor = color ZoomAll End Sub

definingPoint(2) = 0 leaderEndPoint(0) = 10 leaderEndPoint(1) = 5 leaderEndPoint(2) = 0 useXAxis = 5

' 在模型空间中创建坐标标注

Set dimObj = ThisDrawing.ModelSpace. _ AddDimOrdinate(definingPoint, _ leaderEndPoint, useXAxis) ZoomAll End Sub

'本例在模型空间中创建坐标标注。

7.4 Sub Ch5_OverrideDimensionText()

Dim dimObj As AcadDimAligned Dim point1(0 To 2) As Double Dim point2(0 To 2) As Double Dim location(0 To 2) As Double ' 定义标注

point1(0) = 5#: point1(1) = 3#: point1(2) = 0# point2(0) = 10#: point2(1) = 3#: point2(2) = 0# location(0) = 7.5: location(1) = 5#: location(2) = 0#

' 在模型空间中创建对齐标注对象 Set dimObj = ThisDrawing.ModelSpace. _ AddDimAligned(point1, point2, location) ' 修改标注的文本字符串

dimObj.TextOverride = \ dimObj.Update End Sub

'本例向标注值附加了文字，所以既显示字符串，又显示标注值。

7.5 Sub Ch5_CopyDimStyles()

Dim newStyle1 As AcadDimStyle Dim newStyle2 As AcadDimStyle Dim newStyle3 As AcadDimStyle

Set newStyle1 = ThisDrawing.DimStyles.Add _ (\

Call newStyle1.CopyFrom(ThisDrawing.ModelSpace(0)) Set newStyle2 = ThisDrawing.DimStyles.Add _ (\

Call newStyle2.CopyFrom(ThisDrawing.DimStyles.Item _

(\

Set newStyle2 = ThisDrawing.DimStyles.Add _ (\ Call newStyle2.CopyFrom(ThisDrawing) End Sub

'本样例创建三个新的标注样式，并将文档、给定标注样式和给定标注的当前设置分别复制到各个新的标注样式中。如果在运行此样例之前进行适当的设置，将发现创建的是不同的标注样式。

7.6 Sub Ch5_CreateLeader()

Dim leaderObj As AcadLeader Dim points(0 To 8) As Double Dim leaderType As Integer

Dim annotationObject As AcadObject points(0) = 0: points(1) = 0: points(2) = 0 points(3) = 4: points(4) = 4: points(5) = 0 points(6) = 4: points(7) = 5: points(8) = 0 leaderType = acLineWithArrow Set annotationObject = Nothing ' 在模型空间中创建引线对象

Set leaderObj = ThisDrawing.ModelSpace. _

AddLeader(points, annotationObject, leaderType) ZoomAll End Sub

'本例在模型空间中创建引线。引线没有关联的注释。

7.7 Sub Ch5_AddAnnotation()

Dim leaderObj As AcadLeader Dim mtextObj As AcadMText Dim points(0 To 8) As Double

Dim insertionPoint(0 To 2) As Double Dim width As Double

Dim leaderType As Integer

Dim annotationObject As Object

Dim textString As String, msg As String ' 在模型空间中创建 MText 对象 textString = \ insertionPoint(0) = 5 insertionPoint(1) = 5 insertionPoint(2) = 0 width = 2

Set mtextObj = ThisDrawing.ModelSpace. _ AddMText(insertionPoint, width, textString) ' 引线的数据

points(0) = 0: points(1) = 0: points(2) = 0 points(3) = 4: points(4) = 4: points(5) = 0 points(6) = 4: points(7) = 5: points(8) = 0 leaderType = acLineWithArrow

' 在模型空间中创建引线对象，并将 ' MText 对象与引线关联

Set annotationObject = mtextObj

Set leaderObj = ThisDrawing.ModelSpace. _ AddLeader(points, annotationObject, leaderType) ZoomAll End Sub

'本例创建 MText 对象。接着使用 MText 对象作为其注释来创建引线。

7.8 Sub Ch5_CreateTolerance()

Dim toleranceObj As AcadTolerance Dim textString As String

Dim insertionPoint(0 To 2) As Double Dim direction(0 To 2) As Double ' 定义公差对象

textString = \ insertionPoint(0) = 5 insertionPoint(1) = 5 insertionPoint(2) = 0 direction(0) = 1 direction(1) = 1 direction(2) = 0

' 在模型空间中创建公差对象

Set toleranceObj = ThisDrawing.ModelSpace. _

AddTolerance(textString, insertionPoint, direction) ZoomAll End Sub

'本例在模型空间中创建简单的形位公差。

5.5 Sub Ch4_ChangeCircleLinetype()

'本例创建一个圆，然后，本例将试图从 acad.lin 文件中加载线型“CENTER”。如果该线型已存在或者文件不存在，则显示相关消息。最后，本例将圆的线型设置为“CENTER。”。 On Error Resume Next

' 创建圆

Dim circleObj As AcadCircle Dim center(0 To 2) As Double Dim radius As Double

center(0) = 2: center(1) = 2: center(2) = 0 radius = 1

Set circleObj = ThisDrawing.ModelSpace. _ AddCircle(center, radius) Dim linetypeName As String linetypeName = \

'从 acad.lin 文件加载“CENTER”线型

ThisDrawing.Linetypes.Load linetypeName, \If Err.Description <> \'指定圆的线型为“CENTER” circleObj.Linetype = \circleObj.Update End Sub

5.6 Sub Ch4_ListStates()

'如果图层设置已经保存在当前的图形中，则下面的代码列出所有已经保存的图层设置名称： On Error Resume Next

Dim oLSMDict As AcadDictionary Dim XRec As Object

Dim layerstateNames As String layerstateNames = \

'获取 ACAD_LAYERSTATES 词典，它保存在 'Layers 对象的扩展词典中

Set oLSMDict = ThisDrawing.Layers. _

GetExtensionDictionary.Item(\'列出每个己保存的图层设置的名称。设置 '保存为词典中的 XRecord。 For Each XRec In oLSMDict

layerstateNames = layerstateNames + XRec.Name + vbCrLf Next XRec

MsgBox \vbCrLf + layerstateNames End Sub

5.7 Sub Ch4_SaveLayerColorAndLinetype()

'以下代码以 ColorLinetype 的名称保存当前图层的颜色和线型。 Dim oLSM As AcadLayerStateManager

'访问 LayerStateManager 对象

Set oLSM = ThisDrawing.Application. _

GetInterfaceObject(\'将当前图形关联至 LayerStateManager oLSM.SetDatabase ThisDrawing.Database

oLSM.Save \End Sub

5.8 Sub Ch4_RenameLayerSettings()

'以下代码将 ColorLinetype 图层设置重命名为 OldColorLinetype。 Dim oLSM As AcadLayerStateManager Set oLSM = ThisDrawing.Application. _

GetInterfaceObject(\oLSM.SetDatabase ThisDrawing.Database

oLSM.Rename \End Sub

5.9 Sub Ch4_DeleteColorAndLinetype()

'以下代码删除以 ColorLinetype. 名称保存的图层设置。 Dim oLSM As AcadLayerStateManager Set oLSM = ThisDrawing.Application. _

GetInterfaceObject(\oLSM.SetDatabase ThisDrawing.Database oLSM.Delete \End Sub

5.10 Sub Ch4_RestoreLayerSettings()

'假设当前图形中图层的颜色和线型设置先前被保存在名称“ColorLinetype”下，以下代码将把图形中每个图层的颜色和线型都重置为保存“ColorLinetype”时这些设置具有的值。 Dim oLSM As AcadLayerStateManager Set oLSM = ThisDrawing.Application. _

GetInterfaceObject(\oLSM.SetDatabase ThisDrawing.Database oLSM.Restore \

End Sub

5.11 Sub Ch4_ExportLayerSettings()

'以下代码将保存的图层设置输出到名为 Colortype.las 的文件中。 Dim oLSM As AcadLayerStateManager Set oLSM = ThisDrawing.Application. _

GetInterfaceObject(\oLSM.SetDatabase ThisDrawing.Database

oLSM.Export \End Sub

5.12 Sub Ch4_ImportLayerSettings()

'以下代码从名为 Colortype.las 文件输入图层设置。 Dim oLSM As AcadLayerStateManager Set oLSM = ThisDrawing.Application. _

GetInterfaceObject(\oLSM.SetDatabase ThisDrawing.Database '如果要输入的图形未包含

'保存的设置中引用的所有线型， '将返回错误。虽然完成了输入， ' 但使用的是默认线型。 On Error Resume Next

oLSM.Import \If Err.Number = -2145386359 Then ' 错误指出线型没有定义

MsgBox (\' \ End If

On Error GoTo 0 End Sub

6 将文字添加到图形

6.1 Sub Ch4_UpdateTextFont()

MsgBox (\Dim typeFace As String Dim SavetypeFace As String Dim Bold As Boolean

Dim Italic As Boolean Dim charSet As Long

Dim PitchandFamily As Long ' 获取当前设置，填充 'SetFont 方法的默认值

ThisDrawing.ActiveTextStyle.GetFont typeFace, _ Bold, Italic, charSet, PitchandFamily ' 改变字体

SavetypeFace = typeFace typeFace = \

ThisDrawing.ActiveTextStyle.SetFont typeFace, _ Bold, Italic, charSet, PitchandFamily ThisDrawing.Regen acActiveViewport

MsgBox (\ ' 恢复原始字体

ThisDrawing.ActiveTextStyle.SetFont SavetypeFace, _ Bold, Italic, charSet, PitchandFamily ThisDrawing.Regen acActiveViewport End Sub

6.2 Sub Ch4_UpdateTextFont()

'本例获取活动文字样式的当前字体值，并随后将该字体更改为“PlayBill”。然后，将使用 SetFont 方法设置新的字体。要查看字体更改的效果，请在运行样例之前，向当前图形中添加一些多行文字或文字。注意，如果系统上没有 PlayBill 字体，则需要将其替换为一种已有的字体以使本例有效。

MsgBox (\Dim typeFace As String Dim SavetypeFace As String Dim Bold As Boolean Dim Italic As Boolean Dim charSet As Long

Dim PitchandFamily As Long

' 获取当前设置，填充 'SetFont 方法的默认值

ThisDrawing.ActiveTextStyle.GetFont typeFace, _ Bold, Italic, charSet, PitchandFamily

' 改变字体

SavetypeFace = typeFace typeFace = \

ThisDrawing.ActiveTextStyle.SetFont typeFace, _ Bold, Italic, charSet, PitchandFamily ThisDrawing.Regen acActiveViewport

MsgBox (\

' 恢复原始字体

ThisDrawing.ActiveTextStyle.SetFont SavetypeFace, _ Bold, Italic, charSet, PitchandFamily ThisDrawing.Regen acActiveViewport End Sub

6.3 Sub Ch4_ChangeFontFiles()

'本例更改 FontFile 和 BigFontFile 特性。用户需要将本例中的路径信息替换为实际的系统路径和文件名。

ThisDrawing.ActiveTextStyle.BigFontFile = _ ' \

ThisDrawing.ActiveTextStyle.fontFile = _ ' \End Sub

6.4 Sub Ch4_ChangeTextHeight()

'本例创建一行文字，然后修改该文字的高度。 Dim textObj As AcadText Dim textString As String

Dim insertionPoint(0 To 2) As Double Dim height As Double ' 定义 Text 对象

textString = \insertionPoint(0) = 3 insertionPoint(1) = 3 insertionPoint(2) = 0 height = 0.5

'在模型空间中创建 Text 对象

Set textObj = ThisDrawing.ModelSpace. _ AddText(textString, insertionPoint, height) '将 Height 值改为 1 textObj.height = 1 textObj.Update End Sub

6.5 Sub Ch4_ObliqueText()

'本例创建一个 Text 对象，然后将文字倾斜 45 度。 Dim textObj As AcadText Dim textString As String

Dim insertionPoint(0 To 2) As Double Dim height As Double ' 定义 Text 对象

textString = \insertionPoint(0) = 3 insertionPoint(1) = 3 insertionPoint(2) = 0 height = 0.5

'在模型空间中创建 Text 对象

Set textObj = ThisDrawing.ModelSpace. _ AddText(textString, insertionPoint, height) '将 ObliqueAngle 值改为 '45 度（.707 弧度）

textObj.ObliqueAngle = 0.707 textObj.Update End Sub

6.6 Sub Ch4_ChangingTextGenerationFlag()

'本例创建一个文字行，然后使用 TextGenerationFlag 特性将其设置为反向显示。 Dim textObj As AcadText Dim textString As String

Dim insertionPoint(0 To 2) As Double Dim height As Double ' 创建 Text 对象

textString = \insertionPoint(0) = 3 insertionPoint(1) = 3 insertionPoint(2) = 0 height = 0.5

Set textObj = ThisDrawing.ModelSpace. _ AddText(textString, insertionPoint, height) '修改 TextGenerationFlag 的值

textObj.TextGenerationFlag = acTextFlagBackward textObj.Update End Sub

6.7 Sub Ch4_CreateText()

'本例在模型空间中的 (2,2,0) 坐标处创建一行文字。 Dim textObj As AcadText Dim textString As String

Dim insertionPoint(0 To 2) As Double

Dim height As Double

' 创建 Text 对象

textString = \insertionPoint(0) = 2 insertionPoint(1) = 2 insertionPoint(2) = 0 height = 0.5

Set textObj = ThisDrawing.ModelSpace. _ AddText(textString, insertionPoint, height) textObj.Update End Sub

6.8 Sub Ch4_TextAlignment()

Dim textObj As AcadText Dim textString As String

Dim insertionPoint(0 To 2) As Double Dim height As Double

'定义新的 Text 对象

textString = \insertionPoint(0) = 3 insertionPoint(1) = 3 insertionPoint(2) = 0 height = 0.5

'在模型空间中创建 Text 对象

Set textObj = ThisDrawing.ModelSpace. _ AddText(textString, insertionPoint, height) '在文字对齐点上创建一个点， '以便更清楚地看到对齐过程 Dim pointObj As AcadPoint

Dim alignmentPoint(0 To 2) As Double alignmentPoint(0) = 3 alignmentPoint(1) = 3 alignmentPoint(2) = 0

Set pointObj = ThisDrawing.ModelSpace. _ AddPoint(alignmentPoint) pointObj.Color = acRed

'将点样式设置为十字光标

ThisDrawing.SetVariable \ ' 左对齐文字

textObj.Alignment = acAlignmentLeft ThisDrawing.Regen acActiveViewport

MsgBox \ ' 居中对齐文字

textObj.Alignment = acAlignmentCenter

'将文字对齐点（所有文字， ' 左对齐的文字除外。）

textObj.TextAlignmentPoint = alignmentPoint ThisDrawing.Regen acActiveViewport MsgBox \ ' 右对齐文字

textObj.Alignment = acAlignmentRight ThisDrawing.Regen acActiveViewport

MsgBox \end sub

'例创建一个 Text 对象和一个 Point 对象。Point 对象被设置为文字对齐点，并变为红色的十字光标，使其可见。文字对齐将被修改，并显示消息框以终止宏的执行，这样用户就可以查看修改文字对齐的影响。

6.9 Sub Ch4_CreateMText()

Dim mtextObj As AcadMText

Dim insertPoint(0 To 2) As Double Dim width As Double Dim textString As String insertPoint(0) = 2 insertPoint(1) = 2 insertPoint(2) = 0 width = 4

textString = \'在模型空间中创建文字对象

Set mtextObj = ThisDrawing.ModelSpace. _ AddMText(insertPoint, width, textString) ZoomAll End Sub

'以下代码在模型空间中的 (2,2,0) 坐标处创建 MText 对象。

6.10 Sub Ch4_FormatMText()

Dim mtextObj As AcadMText

Dim insertPoint(0 To 2) As Double Dim width As Double Dim textString As String insertPoint(0) = 2 insertPoint(1) = 2 insertPoint(2) = 0 width = 4

' 定义控制字符的 ASCII 字符 Dim OB As Long ' Open Bracket { Dim CB As Long ' Close Bracket } Dim BS As Long ' 反斜杠 \\ Dim FS As Long ' 正斜杠 / Dim SC As Long ' 分号 ; OB = Asc(\ CB = Asc(\ BS = Asc(\ FS = Asc(\ SC = Asc(\

' 将以下控制字符和文字字符 ' 指定给文本字符串：

' {{\\H1.5x; Big text}\\A2; over text\\A1;/\\A0; under text} textString = Chr(OB) + Chr(OB) + Chr(BS) + \ + Chr(SC) + \ + Chr(SC) + \ + Chr(FS) + Chr(BS) + \ + Chr(CB)

' 在模型空间中创建文字对象

Set mtextObj = ThisDrawing.ModelSpace. _ AddMText(insertPoint, width, textString) ZoomAll End Sub

'本例创建并格式化 MText 对象。

7 标注和公差

7.1 Sub Ch5_CreateRadialDimension()

Dim dimObj As AcadDimRadial Dim center(0 To 2) As Double Dim chordPoint(0 To 2) As Double Dim leaderLen As Integer ' 定义标注 center(0) = 0 center(1) = 0 center(2) = 0 chordPoint(0) = 5 chordPoint(1) = 5 chordPoint(2) = 0 leaderLen = 5

' 在模型空间中创建半径标注

Set dimObj = ThisDrawing.ModelSpace. _ AddDimRadial(center, chordPoint, leaderLen) ZoomAll End Sub

'本例在模型空间中创建半径标注。

7.2 Sub Ch5_CreateAngularDimension()

Dim dimObj As AcadDimAngular Dim angVert(0 To 2) As Double Dim FirstPoint(0 To 2) As Double Dim SecondPoint(0 To 2) As Double Dim TextPoint(0 To 2) As Double ' 定义标注 angVert(0) = 0 angVert(1) = 5 angVert(2) = 0 FirstPoint(0) = 1 FirstPoint(1) = 7 FirstPoint(2) = 0 SecondPoint(0) = 1 SecondPoint(1) = 3 SecondPoint(2) = 0 TextPoint(0) = 3 TextPoint(1) = 5 TextPoint(2) = 0

' 在模型空间中创建角度标注

Set dimObj = ThisDrawing.ModelSpace. _

AddDimAngular(angVert, FirstPoint, SecondPoint, TextPoint) ZoomAll End Sub

'本例在模型空间中创建角度标注。

7.3 Sub Ch5_CreatingOrdinateDimension()

Dim dimObj As AcadDimOrdinate Dim definingPoint(0 To 2) As Double Dim leaderEndPoint(0 To 2) As Double Dim useXAxis As Long ' 定义标注

definingPoint(0) = 5 definingPoint(1) = 5

本文来源：https://www.bwwdw.com/article/szev.html