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

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

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