如何进行块操作以及填充（带实例）
<p><font face="System">Sub CPT()</font></p><p><font face="System">Dim myLayer As AcadLayer</font></p><p><font face="System">Dim myBlock As AcadBlock<br/>Dim p0(0 To 2) As Double</font></p><p><br/><font face="System">Dim arc1 As AcadArc<br/>Dim arc2 As AcadArc<br/>Dim arc3 As AcadArc<br/>Dim arc_p1 As Variant<br/>Dim arc_p2 As Variant<br/>Dim arc_p3 As Variant</font></p><p><font face="System">Dim mySelect(0 To 7) As AcadEntity<br/>Dim myOuterLoop(0 To 2) As AcadEntity<br/>Dim hatchObj As AcadHatch</font></p><p><font face="System">'设置层属性<br/>Set myLayer = ThisDrawing.Layers.Add("000_GI_CPT") '新增层<br/>myLayer.Lineweight = acLnWt035 '设定层的线性<br/>myLayer.color = 6 '设定层的颜色为粉色<br/>ThisDrawing.ActiveLayer = myLayer '设定该层为当前层</font></p><p><font face="System">p0(0) = 0<br/>p0(1) = 0<br/>p0(2) = 0</font></p><p><font face="System">'绘制填充边界<br/>Set arc1 = ThisDrawing.ModelSpace.AddArc(p0, r, -pi / 2, pi / 6)<br/>arc_p1 = arc1.StartPoint<br/>Set arc2 = ThisDrawing.ModelSpace.AddArc(p0, r, pi / 6, 5 * pi / 6)<br/>arc_p2 = arc2.StartPoint<br/>Set arc3 = ThisDrawing.ModelSpace.AddArc(p0, r, 5 * pi / 6, 3 * pi / 2)<br/>arc_p3 = arc3.StartPoint</font></p><p><font face="System">Set myOuterLoop(0) = ThisDrawing.ModelSpace.AddLine(arc_p1, arc_p2)<br/>Set myOuterLoop(1) = ThisDrawing.ModelSpace.AddLine(arc_p2, arc_p3)<br/>Set myOuterLoop(2) = ThisDrawing.ModelSpace.AddLine(arc_p3, arc_p1)</font></p><p><font face="System">'进行填充<br/>Set hatchObj = ThisDrawing.ModelSpace.AddHatch(0, "solid", True) '创建填充对象为实心填充<br/>Call hatchObj.AppendOuterLoop(myOuterLoop) '将外边界加入到其中<br/>Call hatchObj.Evaluate '必须先计算填充范围<br/>Call hatchObj.Update '填充操作应刷新</font></p><p><font face="System">'删除选择集<br/>Set mySelect(0) = myOuterLoop(0)<br/>Set mySelect(1) = myOuterLoop(1)<br/>Set mySelect(2) = myOuterLoop(2)<br/>Set mySelect(3) = arc1<br/>Set mySelect(4) = arc2<br/>Set mySelect(5) = arc3<br/>Set mySelect(6) = ThisDrawing.ModelSpace.AddCircle(p0, r)<br/>Set mySelect(7) = hatchObj<br/>Set myBlock = ThisDrawing.Blocks.Add(p0, "静力触探孔")<br/>Call ThisDrawing.ModelSpace.InsertBlock(p0, "静力触探孔", 1, 1, 1, 0)<br/>Call ThisDrawing.CopyObjects(mySelect, myBlock)</font></p><p><font face="System">For Each element In mySelect '删除除块以外的线<br/>element.Delete<br/>Next</font></p><p><font face="System">ZoomExtents<br/>End Sub<br/></font></p><p><font face="System"></font> </p><p><font face="System">上面的代码是在图上画一个勘探孔的符号，这里已经把他做成了块，但问题是我双击块的时候发现其中线以及填充都重复画了好几次，比如其中的园画了5个，但是我代码里面只画了一次，麻烦高人给小弟指点一下</font></p> 是不是copyobjects的目标对象不是你的块？。如果没有指定所有者，对象将被创建到与 Objects 数组中的对象相同的所有者中。
页:
[1]