如何进行块操作以及填充（带实例）

mytongji

Sub CPT()

Dim myLayer As AcadLayer

Dim myBlock As AcadBlock
Dim p0(0 To 2) As Double

Dim arc1 As AcadArc
Dim arc2 As AcadArc
Dim arc3 As AcadArc
Dim arc_p1 As Variant
Dim arc_p2 As Variant
Dim arc_p3 As Variant

Dim mySelect(0 To 7) As AcadEntity
Dim myOuterLoop(0 To 2) As AcadEntity
Dim hatchObj As AcadHatch

'设置层属性
Set myLayer = ThisDrawing.Layers.Add("000_GI_CPT")      '新增层
myLayer.Lineweight = acLnWt035      '设定层的线性
myLayer.color = 6       '设定层的颜色为粉色
ThisDrawing.ActiveLayer = myLayer       '设定该层为当前层

p0(0) = 0
p0(1) = 0
p0(2) = 0

'绘制填充边界
Set arc1 = ThisDrawing.ModelSpace.AddArc(p0, r, -pi / 2, pi / 6)
arc_p1 = arc1.StartPoint
Set arc2 = ThisDrawing.ModelSpace.AddArc(p0, r, pi / 6, 5 * pi / 6)
arc_p2 = arc2.StartPoint
Set arc3 = ThisDrawing.ModelSpace.AddArc(p0, r, 5 * pi / 6, 3 * pi / 2)
arc_p3 = arc3.StartPoint

Set myOuterLoop(0) = ThisDrawing.ModelSpace.AddLine(arc_p1, arc_p2)
Set myOuterLoop(1) = ThisDrawing.ModelSpace.AddLine(arc_p2, arc_p3)
Set myOuterLoop(2) = ThisDrawing.ModelSpace.AddLine(arc_p3, arc_p1)

'进行填充
Set hatchObj = ThisDrawing.ModelSpace.AddHatch(0, "solid", True)        '创建填充对象为实心填充
Call hatchObj.AppendOuterLoop(myOuterLoop)        '将外边界加入到其中
Call hatchObj.Evaluate      '必须先计算填充范围
Call hatchObj.Update        '填充操作应刷新

'删除选择集
Set mySelect(0) = myOuterLoop(0)
Set mySelect(1) = myOuterLoop(1)
Set mySelect(2) = myOuterLoop(2)
Set mySelect(3) = arc1
Set mySelect(4) = arc2
Set mySelect(5) = arc3
Set mySelect(6) = ThisDrawing.ModelSpace.AddCircle(p0, r)
Set mySelect(7) = hatchObj
Set myBlock = ThisDrawing.Blocks.Add(p0, "静力触探孔")
Call ThisDrawing.ModelSpace.InsertBlock(p0, "静力触探孔", 1, 1, 1, 0)
Call ThisDrawing.CopyObjects(mySelect, myBlock)

For Each element In mySelect             '删除除块以外的线
element.Delete
Next

ZoomExtents
End Sub

 

上面的代码是在图上画一个勘探孔的符号，这里已经把他做成了块，但问题是我双击块的时候发现其中线以及填充都重复画了好几次，比如其中的园画了5个，但是我代码里面只画了一次，麻烦高人给小弟指点一下

crazylsp

是不是copyobjects的目标对象不是你的块？。如果没有指定所有者，对象将被创建到与 Objects 数组中的对象相同的所有者中。