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) = \