关于图案填充的一个问题，请高手指点！
本帖最后由 作者 于 2007-7-1 22:51:49 编辑 <br /><br /> <p>最近编制一份投标书，要画一些地层比例图，由于EXCEL一次只能画一个，转到WORD里不好调整，文字大小都不能统一，于是就用VBA编制一个能画饼图的程序，可是在画图例框的时候就出错了，请高的们看看，给小弟仔细点一下。代码如下：</p><p>Sub 饼图()<br/> Dim p1() As Double<br/> p1 = ThisDrawing.Utility.GetPoint(, "输入圆心")<br/> Dim sumpercent As Double<br/> sumpercent = 0<br/> Do<br/> On Error GoTo e<br/> Dim per As Double<br/> per = ThisDrawing.Utility.GetReal("输入百分比：")<br/> sumpercent = sumpercent + per<br/> Dim tc As String<br/> tc = ThisDrawing.Utility.GetString(8, "输入土层名称：")<br/> Dim ang As Double<br/> ang = per / 100 * 360<br/> Dim ang1 As Double<br/> Dim ang2 As Double<br/> ang1 = ang / 180 * 3.14159265<br/> ang1 = ang2 + ang1<br/> ang2 = 0</p><p> If sumpercent = 100 Then<br/> Call hatch(p1, ang2, 0, per)<br/> Else<br/> Call hatch(p1, ang2, ang1, per)<br/> End If<br/> ang2 = ang1<br/> x = 0<br/> Call legend(p1, tc, x)</p><p> x = x + 8<br/> Loop<br/>e:<br/>End Sub</p><p>Function legend(basepoint() As Double, stratumname As String, x As Variant) As Double<br/>Dim p(0 To 11) As Double<br/>p(0) = basepoint(0) - 35<br/>p(1) = basepoint(1) - 40 - x<br/>p(2) = 0</p><p>p(3) = basepoint(0) - 29<br/>p(4) = basepoint(1) - 40 - x<br/>p(5) = 0</p><p>p(6) = basepoint(0) - 29<br/>p(7) = basepoint(1) - 44.8 - x<br/>p(8) = 0</p><p>p(9) = basepoint(0) - 35<br/>p(10) = basepoint(1) - 44.8 - x<br/>p(11) = 0</p><p>Dim stratum As AcadPolyline<br/>Set stratum = ThisDrawing.ModelSpace.AddPolyline(p)<br/>stratum.Closed = True</p><p>Dim addhatch As AcadHatch<br/>Set addhatch = ThisDrawing.ModelSpace.addhatch(0, "solid", True)<br/>addhatch.AppendOuterLoop (stratum) <font color="#ff0000">在这个地方就出错了<br/></font>Dim insertpoint() As Double<br/>insertpoint(0) = basepoint(0) - 26<br/>insertpoint(1) = basepoint(1) - 44.8 - x<br/>insertpoint(2) = 0<br/>Dim sntext As AcadText<br/>Set sntext = ThisDrawing.ModelSpace.AddText(stratumname, p, 5)<br/>End Function<br/>Function hatch(centerpoint() As Double, startangle As Double, endangle As Double, percent As Double) As Double<br/>Dim outerLoop(0 To 2) As AcadEntity<br/>Set outerLoop(0) = ThisDrawing.ModelSpace.AddArc(centerpoint, 30, startangle, endangle)<br/>Set outerLoop(1) = ThisDrawing.ModelSpace.AddLine(centerpoint, outerLoop(0).StartPoint)<br/>Set outerLoop(2) = ThisDrawing.ModelSpace.AddLine(outerLoop(0).EndPoint, centerpoint)<br/>Dim text1 As AcadText<br/>Set text1 = ThisDrawing.ModelSpace.AddText(percent & "%", outerLoop(0).EndPoint, 5)<br/>Angle = endangle / 3.14159265 * 360<br/>If Angle < 90 Then<br/>Else<br/> If Angle < 270 Then<br/>text1.GetBoundingBox minpoint, maxpoint<br/>text1.Move maxpoint, outerLoop(0).EndPoint<br/> End If<br/>End If<br/>Dim bh As AcadHatch<br/>Set bh = ThisDrawing.ModelSpace.addhatch(0, "solid", True)<br/>bh.AppendOuterLoop (outerLoop)<br/>outerLoop(2).Delete<br/>End Function<br/></p><p></p><p>还想请教一下怎么改变填充图案的颜色啊？</p> <p>没有一个人回答！！</p><p>晕了！！</p><p>不过我自己解决了！</p>
页:
[1]