CAD实用VBA.doc

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 + _
" is the first entity in model space." 否则
MsgBox "There are no objects in model space."
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("MyLayer")
If Err <> 0 Then
MsgBox "The layer '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 = "ANSI31"
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("SS2")
FilterType(0) = 0 ' 表示过滤器是对象类型
FilterData(0) = "Circle" ' 表示对象类型是“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("SS4")
FilterType(0) = 0
FilterData(0) = "Circle"
FilterType(1) = 8
FilterData(1) = "0"
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("SS5")
FilterType(0) = 0
FilterData(0) = "Circle"
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("SS6")
FilterType(0) = -4
FilterData(0) = "<or"
FilterType(1) = 0
FilterData(1) = "TEXT"
FilterType(2) = 0
FilterData(2) = "MTEXT"
FilterType(3) = -4
FilterData(3) = "or>"
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("SS10")
FilterType(0) = 0
FilterData(0) = "MTEXT"
FilterType(1) = 1
FilterData(1) = "*The*"
sstext.SelectByPolygon mode, pointsArray, FilterType, FilterData
End Sub
2.6 Sub GetObjInSet()
'请使用名称来引用已知的现有选择集。下例引用名为“SS10”的选择集：
Dim selset As AcadSelectionSet
Set selset = ThisDrawing.SelectionSets("SS10")
MsgBox ("Selection set " $ selset.Name $ " contains " $ _
selset.Count $ " items")
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 "Selection set " $ CStr(i) $ " is: " $ selset.Name
'现在查找选择集中的每个对象，同时显示其类型
j = 0
For Each ent In selset
MsgBox "Item " $ CStr(j + 1) $ " in " $ selset.Name _
' $ "is: " $ ent.EntityName
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("NewLayer")
' 更改图层的名称
layerObj.Name = "MyLayer"
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 "Exploded Object " $ I $ ": " $ _
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 = "ANSI31"
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 Doub