关于图案填充的一个问题，请高手指点！

rielzhou

最近编制一份投标书，要画一些地层比例图，由于EXCEL一次只能画一个，转到WORD里不好调整，文字大小都不能统一，于是就用VBA编制一个能画饼图的程序，可是在画图例框的时候就出错了，请高的们看看，给小弟仔细点一下。代码如下：

Sub 饼图()
    Dim p1() As Double
    p1 = ThisDrawing.Utility.GetPoint(, "输入圆心")
    Dim sumpercent As Double
    sumpercent = 0
    Do
        On Error GoTo e
        Dim per As Double
        per = ThisDrawing.Utility.GetReal("输入百分比：")
        sumpercent = sumpercent + per
        Dim tc As String
        tc = ThisDrawing.Utility.GetString(8, "输入土层名称：")
        Dim ang As Double
        ang = per / 100 * 360
        Dim ang1 As Double
        Dim ang2 As Double
        ang1 = ang / 180 * 3.14159265
        ang1 = ang2 + ang1
        ang2 = 0

        If sumpercent = 100 Then
            Call hatch(p1, ang2, 0, per)
            Else
            Call hatch(p1, ang2, ang1, per)
        End If
        ang2 = ang1
        x = 0
        Call legend(p1, tc, x)

        x = x + 8
    Loop
e:
End Sub

Function legend(basepoint() As Double, stratumname As String, x As Variant) As Double
Dim p(0 To 11) As Double
p(0) = basepoint(0) - 35
p(1) = basepoint(1) - 40 - x
p(2) = 0

p(3) = basepoint(0) - 29
p(4) = basepoint(1) - 40 - x
p(5) = 0

p(6) = basepoint(0) - 29
p(7) = basepoint(1) - 44.8 - x
p(8) = 0

p(9) = basepoint(0) - 35
p(10) = basepoint(1) - 44.8 - x
p(11) = 0

Dim stratum As AcadPolyline
Set stratum = ThisDrawing.ModelSpace.AddPolyline(p)
stratum.Closed = True

Dim addhatch As AcadHatch
Set addhatch = ThisDrawing.ModelSpace.addhatch(0, "solid", True)
addhatch.AppendOuterLoop (stratum)　在这个地方就出错了
Dim insertpoint() As Double
insertpoint(0) = basepoint(0) - 26
insertpoint(1) = basepoint(1) - 44.8 - x
insertpoint(2) = 0
Dim sntext As AcadText
Set sntext = ThisDrawing.ModelSpace.AddText(stratumname, p, 5)
End Function
Function hatch(centerpoint() As Double, startangle As Double, endangle As Double, percent As Double) As Double
Dim outerLoop(0 To 2) As AcadEntity
Set outerLoop(0) = ThisDrawing.ModelSpace.AddArc(centerpoint, 30, startangle, endangle)
Set outerLoop(1) = ThisDrawing.ModelSpace.AddLine(centerpoint, outerLoop(0).StartPoint)
Set outerLoop(2) = ThisDrawing.ModelSpace.AddLine(outerLoop(0).EndPoint, centerpoint)
Dim text1 As AcadText
Set text1 = ThisDrawing.ModelSpace.AddText(percent & "%", outerLoop(0).EndPoint, 5)
Angle = endangle / 3.14159265 * 360
If Angle < 90 Then
Else
    If Angle < 270 Then
text1.GetBoundingBox minpoint, maxpoint
text1.Move maxpoint, outerLoop(0).EndPoint
    End If
End If
Dim bh As AcadHatch
Set bh = ThisDrawing.ModelSpace.addhatch(0, "solid", True)
bh.AppendOuterLoop (outerLoop)
outerLoop(2).Delete
End Function

还想请教一下怎么改变填充图案的颜色啊？

rielzhou

没有一个人回答！！

晕了！！

不过我自己解决了！