015集——CAD vba 填充(hatch)及挖空

原创已于 2024-03-09 12:37:56 修改 · 1.2k 阅读

12 ·

CC 4.0 BY-SA版权

文章标签：

#CAD vba

于 2024-03-06 21:43:08 首次发布

CAD VBA 专栏收录该内容

77 篇文章

订阅专栏

文章介绍了使用AutoCAD编程实现绘制椭圆、正方形、圆形及空心填充的步骤，展示了如何通过AcadHatch对象进行多边形和圆形的边界定义以及图案填充的调整。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

首先，画个椭圆，并填充，直接上代码：


Sub 画椭圆填充()
'2024年3月6日21:10:22 by qq443440204
Dim hat As AcadHatch '填充
Dim ell(0) As AcadEllipse '椭圆
Dim ell1(0) As AcadEllipse '椭圆
Dim cent(0 To 2) As Double '椭圆中心点
Dim dd(0 To 2) As Double '椭圆长轴端点
Dim dd1(0 To 2) As Double '椭圆长轴端点
'先画个椭圆
cent(0) = 400000: cent(1) = 3800000
dd(0) = 100: dd(1) = 1000  'xy轴长度
dd1(0) = 50: dd1(1) = 500  'xy轴长度
rr = 0.4 '长短轴比率
Set ell(0) = ThisDrawing.ModelSpace.AddEllipse(cent, dd, rr)
Set ell1(0) = ThisDrawing.ModelSpace.AddEllipse(cent, dd1, rr)
'开始填充
Set hat = ThisDrawing.ModelSpace.AddHatch(0, "AR-B816", True) '建填充对象
hat.AppendOuterLoop ell '以ell数组为边界
hat.AppendInnerLoop ell1 '以ell数组为边界
hat.PatternScale = 1 '修改填充比例
hat.PatternAngle = 3.14159 / 4 '修改填充角度
hat.Evaluate
ZoomExtents
End Sub

效果如下：

再画个外围正方形，内围圆，填充中间部分。

'2024年3月6日21:13:29 by qq443440204
Sub 空心填充()
Dim 总孔数 As Integer
Dim hobj As AcadHatch
Dim c1(0) As AcadCircle, cc1(2) As Double
Dim c2 As AcadCircle, cc2(2) As Double
Dim box(0) As AcadLWPolyline
Dim p1(2) As Double, p2(2) As Double
Dim 小孔数组() As Object
Dim mycircle(0) As AcadCircle
总孔数 = 8
Set c1(0) = ThisDrawing.ModelSpace.AddCircle(cc1, 60) '画圆
p1(0) = -100: p1(1) = -100
p2(0) = 100: p2(1) = 100
Set box(0) = 画长方形(p1, p2) '画正方形
Set hobj = ThisDrawing.ModelSpace.AddHatch(0, "ansi32", True) '建填充对象
hobj.AppendInnerLoop box '以box数组为内边界
hobj.AppendOuterLoop c1 '以c1数组为外边界
'cc2(1) = 80 '小圆y坐标
'Set c2 = ThisDrawing.ModelSpace.AddCircle(cc2, 10) '画1个小圆
'小孔数组 = c2.ArrayPolar(总孔数 + 1, 2 * 3.14, cc1) '阵列成8个，首尾相连，故+1
'c2.Delete
'Stop
'For ii = 0 To 总孔数 - 1
'  Set mycircle(0) = 小孔数组(ii)
'  hobj.InsertLoopAt 0, acHatchLoopTypeDefault, mycircle '按给定索引在图案填充中插入边界,既在填充里挖掉小孔
'Next ii
'hobj.PatternSpace = 2 '修改间距
hobj.Evaluate
ZoomExtents
End Sub

Function 画长方形(p1, p2) As AcadLWPolyline '用对角线画矩形
Dim boxp(0 To 7) As Double
boxp(0) = p1(0): boxp(1) = p1(1)
boxp(2) = p1(0): boxp(3) = p2(1)
boxp(4) = p2(0): boxp(5) = p2(1)
boxp(6) = p2(0): boxp(7) = p1(1)
Set 画长方形 = ThisDrawing.ModelSpace.AddLightWeightPolyline(boxp)
画长方形.Closed = True
End Function

最后在填充中阵列一些小圆，并挖空小圆中的填充

'2024年3月6日21:13:29 by qq443440204
Sub 空心填充()
Dim 总孔数 As Integer
Dim hobj As AcadHatch
Dim c1(0) As AcadCircle, cc1(2) As Double
Dim c2 As AcadCircle, cc2(2) As Double
Dim box(0) As AcadLWPolyline
Dim p1(2) As Double, p2(2) As Double
Dim 小孔数组() As Object
Dim mycircle(0) As AcadCircle
总孔数 = 8
Set c1(0) = ThisDrawing.ModelSpace.AddCircle(cc1, 60) '画圆
p1(0) = -100: p1(1) = -100
p2(0) = 100: p2(1) = 100
Set box(0) = 画长方形(p1, p2) '画正方形
Set hobj = ThisDrawing.ModelSpace.AddHatch(0, "ansi32", True) '建填充对象
hobj.AppendInnerLoop box '以box数组为内边界
hobj.AppendOuterLoop c1 '以c1数组为外边界
cc2(1) = 80 '小圆y坐标
Set c2 = ThisDrawing.ModelSpace.AddCircle(cc2, 10) '画1个小圆
小孔数组 = c2.ArrayPolar(总孔数 + 1, 2 * 3.14, cc1) '阵列成8个，首尾相连，故+1
c2.Delete
For ii = 0 To 总孔数 - 1
  Set mycircle(0) = 小孔数组(ii)
  hobj.InsertLoopAt 0, acHatchLoopTypeDefault, mycircle '按给定索引在图案填充中插入边界,既在填充里挖掉小孔
Next ii
hobj.PatternSpace = 2 '修改间距
hobj.Evaluate
ZoomExtents
End Sub

Function 画长方形(p1, p2) As AcadLWPolyline '用对角线画矩形
Dim boxp(0 To 7) As Double
boxp(0) = p1(0): boxp(1) = p1(1)
boxp(2) = p1(0): boxp(3) = p2(1)
boxp(4) = p2(0): boxp(5) = p2(1)
boxp(6) = p2(0): boxp(7) = p1(1)
Set 画长方形 = ThisDrawing.ModelSpace.AddLightWeightPolyline(boxp)
画长方形.Closed = True
End Function