发布时间 : 星期日 文章CAD实用VBA更新完毕开始阅读7ec12cf91eb91a37f0115c1d
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) = \