[VBA程序]：求助：图案填充总是出错

gzmkshjsh

自己编了图案填充程序如下：
Sub testH()
Dim B As Double
Dim h As Double
Dim d As Double
Dim m As Double
Dim x, y As Double
x = 200
y = 200

B = 4200
h = 2200
d = 100
m = 100

Dim spt1(0 To 2) As Double, ept1(0 To 2) As Double
Dim spt2(0 To 2) As Double, ept2(0 To 2) As Double
Dim spt3(0 To 2) As Double, ept3(0 To 2) As Double
Dim spt4(0 To 2) As Double, ept4(0 To 2) As Double
Dim spt5(0 To 2) As Double, ept5(0 To 2) As Double
Dim spt6(0 To 2) As Double, ept6(0 To 2) As Double
Dim Pline1 As AcadLWPolyline, Pline2 As AcadLWPolyline
Dim Pline3 As AcadLWPolyline, Pline4 As AcadLWPolyline
Dim Points1(0 To 7) As Double, Points2(0 To 7) As Double
Dim Points3(0 To 7) As Double, Points4(0 To 7) As Double
Dim Arc1 As AcadArc
Dim Arc2 As AcadArc
Dim Center(0 To 2) As Double
Dim Radius1 As Double
Dim Radius2 As Double
Dim sAg As Double, eAg As Double
Const pi = 3.1415926


    Points3(0) = x + gb
    Points3(1) = y
    Points3(2) = x + gb
    Points3(3) = y - gs
    Points3(4) = x + gb + gk
    Points3(5) = y - gs
    Points3(6) = x + gb + gk
    Points3(7) = y
   
    Points4(0) = x
    Points4(1) = y
    Points4(2) = x
    Points4(3) = y - gs - gb
    Points4(4) = x + 2 * gb + gk
    Points4(5) = y - gs - gb
    Points4(6) = x + 2 * gb + gk
    Points4(7) = y
   

Points1(0) = x - d
Points1(1) = y + h
Points1(2) = x - d
Points1(3) = y - m
Points1(4) = x
Points1(5) = y - m
Points1(6) = x
Points1(7) = y + h

Points2(0) = x + B
Points2(1) = y + h
Points2(2) = x + B
Points2(3) = y - m
Points2(4) = x + B + d
Points2(5) = y - m
Points2(6) = x + B + d
Points2(7) = y + h

Center(0) = x + B / 2
Center(1) = y + h
Radius2 = B / 2 + d
Radius1 = B / 2
sAg = 0
eAg = 3.14159265

Set Pline1 = ThisDrawing.ModelSpace.AddLightWeightPolyline(Points1)
Set Pline2 = ThisDrawing.ModelSpace.AddLightWeightPolyline(Points2)
Set Pline3 = ThisDrawing.ModelSpace.AddLightWeightPolyline(Points3)
Set Pline4 = ThisDrawing.ModelSpace.AddLightWeightPolyline(Points4)
Set Arc1 = ThisDrawing.ModelSpace.AddArc(Center, Radius1, sAg, eAg)
Set Arc2 = ThisDrawing.ModelSpace.AddArc(Center, Radius2, sAg, eAg)
Dim hatchObj As AcadHatch
Dim patternName As String
Dim patternType As Long
Dim bAssociativity As Boolean


patternName = "AR-CONC"
'patternName = "ANSI31"
patternType = 0
bAssociativity = True
Set hatchObj = ThisDrawing.ModelSpace.AddHatch(patternType, patternName, bAssociativity)

Dim outerLoop(0 To 3) As AcadEntity
Dim outerLoop1(0 To 0) As AcadEntity
Dim outerLoop2(0 To 0) As AcadEntity
Dim outerLoop3(0 To 3) As AcadEntity

Set outerLoop(0) = Arc1
Set outerLoop(1) = Arc2
Set outerLoop(2) = ThisDrawing.ModelSpace.AddLine(outerLoop(0).StartPoint, outerLoop(1).StartPoint)
Set outerLoop(3) = ThisDrawing.ModelSpace.AddLine(outerLoop(0).EndPoint, outerLoop(1).EndPoint)

Set outerLoop1(0) = ThisDrawing.ModelSpace.AddLightWeightPolyline(Points1)
outerLoop1(0).Closed = True

Set outerLoop2(0) = ThisDrawing.ModelSpace.AddLightWeightPolyline(Points2)
outerLoop2(0).Closed = True


hatchObj.AppendOuterLoop (outerLoop)
hatchObj.AppendOuterLoop (outerLoop1)
hatchObj.AppendOuterLoop (outerLoop2)
'hatchObj.Evaluate


hatchObj.PatternSpace = hatchObj.PatternSpace + 30

hatchObj.Evaluate
ThisDrawing.Regen True

End Sub
程序运行时当B和h数据较大时，总是说程序出错，出错原因是填充图案太密。
但是绘完的图在CAD中修改填充比例后（与程序中的值相等）却能显示出来，不知什么原因。
请斑竹指导？

雪山飞狐(lzh)

把填充比例改小试试

gzmkshjsh

填充比例改小更不行。如果调整比例为一合适值后，当改变B或h较大时，又会出现填充图案太密的错误。
上例所绘制图所下：

dgp000

PatternSpace是间距，scale才是比例，设一下比例试试！

gzmkshjsh

使用PatternScale设置其填充比例，当B或h较大时也出现填充图案太密的错误码。但是相同的PatternScale值在CAD中却能填充且正常显示。不知为什么？
有没有一种方法处理不管图形多大都能正常填充？请高手解决！！！

雪山飞狐(lzh)

程序的浮点计算误差引起的，没办法避免，只有自己按图形尺寸大致计算一下，给一个大致的比例关系

gzmkshjsh

谢谢斑竹。
能不能编程解决这个问题？