[求助]：怎样用VBA实现这样的填充?

小玩童

哪位高手可以帮忙，谢谢！

yunzhong80

看看这个例程你就知道了
Sub Ch4_AppendInnerLoopToHatch()
    Dim hatchObj As AcadHatch
    Dim patternName As String
    Dim PatternType As Long
    Dim bAssociativity As Boolean
   
    ' 定义和创建图案填充
    patternName = "ANSI31"
    PatternType = 0
    bAssociativity = True
    Set hatchObj = ThisDrawing.ModelSpace. _
        AddHatch(PatternType, patternName, bAssociativity)
   
    ' 创建图案填充的外部环
    Dim outerLoop(0 To 1) As AcadEntity
    Dim center(0 To 2) As Double
    Dim radius As Double
    Dim startAngle As Double
    Dim endAngle As Double
    center(0) = 5: center(1) = 3: center(2) = 0
    radius = 3
    startAngle = 0
    endAngle = 3.141592
    Set outerLoop(0) = ThisDrawing.ModelSpace. _
       AddArc(center, radius, startAngle, endAngle)
    Set outerLoop(1) = ThisDrawing.ModelSpace. _
       AddLine(outerLoop(0).startPoint, outerLoop(0).endPoint)
        
    ' 将外部环附加到 Hatch 对象
    hatchObj.AppendOuterLoop (outerLoop)
   
    ' 创建一个圆作为图案填充的内部环
    Dim innerLoop(0) As AcadEntity
    center(0) = 5: center(1) = 4.5: center(2) = 0
    radius = 1
    Set innerLoop(0) = ThisDrawing.ModelSpace. _
                                 AddCircle(center, radius)
   
    ' 将圆作为内部环附加到图案填充
    hatchObj.AppendInnerLoop (innerLoop)
   
    ' 计算并显示图案填充
    hatchObj.Evaluate
    ThisDrawing.Regen True
End Sub

小玩童

楼上的大哥，我写了下面的代码来实现填充效果，但是添加内部边界就出错，你给的例子我也看过，只有一个内部边界，麻烦你看看我的代码，谢谢！
Sub HH()
'On Error Resume Next
Dim ent As AcadEntity
Dim Pname As String
Dim Ptype As Long
Dim Ba As Boolean
Dim hatchObj As AcadHatch
Pname = "ANSI33" '填充样式
Ptype = acHatchPatternTypePreDefined '填充类型
Ba = True '是否关联
Dim Outer(0 To 0) As AcadEntity


Dim i As Integer
Dim j As Integer
Dim s As Integer
Dim Plobj As AcadPolyline
Dim coor As Variant
Dim coords As Variant
Dim pnt As Variant
Dim Sset As AcadSelectionSet




'clearsset

Set Sset = ThisDrawing.SelectionSets.Add("GD")

ThisDrawing.Utility.GetEntity ent, pnt, "c"

coords = ent.Coordinates


Sset.SelectByPolygon acSelectionSetWindowPolygon, coords



Dim K As Integer


ReDim Inner(0 To Sset.Count - 1) As AcadEntity



For K = 0 To Sset.Count - 1


    Set Inner(K) = Sset.Item(K)


Next
Sset.Delete
Set Outer(0) = ent '定义填充外边界

Set hatchObj = ThisDrawing.ModelSpace.AddHatch(Ptype, Pname, Ba)
'Hatchobj.HatchStyle = acHatchStyleOuter
hatchObj.AppendOuterLoop Outer

hatchObj.AppendInnerLoop Inner

hatchObj.Evaluate


ThisDrawing.Regen True


End Sub

yunzhong80

'你是选择的边界啊，如果选择了边界还用程序来干吗
'你看看这个好不好玩
Sub Ch4_AppendInnerLoopToHatch()
    Dim hatchObj As AcadHatch
    Dim patternName As String
    Dim PatternType As Long
    Dim bAssociativity As Boolean
  
   
    ' 定义和创建图案填充
    patternName = "ANSI31"
    PatternType = 0
    bAssociativity = True
    Set hatchObj = ThisDrawing.ModelSpace. _
        AddHatch(PatternType, patternName, bAssociativity)
   
    ' 创建图案填充的外部环
    Dim outerLoop(0 To 0) As AcadEntity
    Dim center(0 To 2) As Double
    Dim radius As Double
    Dim startAngle As Double
    Dim endAngle As Double
    center(0) = 0: center(1) = 0: center(2) = 0
    radius = 100
      Set outerLoop(0) = ThisDrawing.ModelSpace. _
                                 AddCircle(center, radius)
        
    ' 将外部环附加到 Hatch 对象
    hatchObj.AppendOuterLoop (outerLoop)
   
    ' 创建一个圆作为图案填充的内部环
     Dim innerLoop(0) As AcadEntity
        center(0) = 40: center(1) = 20: center(2) = 0
        radius = 20
        Set innerLoop(0) = ThisDrawing.ModelSpace. _
                                 AddCircle(center, radius)
       ' 将圆作为内部环附加到图案填充
    hatchObj.AppendInnerLoop (innerLoop)
   
     ' 创建一个圆作为图案填充的内部环
    center(0) = -40: center(1) = 20: center(2) = 0
        radius = 20
       Set innerLoop(0) = ThisDrawing.ModelSpace. _
                                 AddCircle(center, radius)
      ' 将圆作为内部环附加到图案填充
          hatchObj.AppendInnerLoop (innerLoop)
           
    ' 创建一个圆作为图案填充的内部环
    Dim ptmajoraxis(0 To 2) As Double
    ptmajoraxis(0) = 20: ptmajoraxis(1) = 0: ptmajoraxis(2) = 0
    center(0) = 0: center(1) = -60: center(2) = 0
    Set innerLoop(0) = ThisDrawing.ModelSpace.AddEllipse(center, ptmajoraxis, 0.3)
          ' 将圆作为内部环附加到图案填充
    hatchObj.AppendInnerLoop (innerLoop)
   
   
    ' 计算并显示图案填充
    hatchObj.Evaluate
    ThisDrawing.Regen True
End Sub

小玩童

呵，大哥你的程序很有意思，看了以后获益匪浅，我把程序改了一下，可以填充了，不过就是在'hatchObj.Evaluate总出错，于是注释掉这行，所以要全部重生成下才可以显示阴影线，麻烦您看看我的代码，是哪里有问题？非常感谢!
Sub HH()
'On Error Resume Next
Dim ent As AcadEntity
Dim Pname As String
Dim Ptype As Long
Dim Ba As Boolean
Dim hatchObj As AcadHatch
Pname = "ANSI33" '填充样式
Ptype = acHatchPatternTypePreDefined '填充类型
Ba = True '是否关联
Dim Outer(0 To 0) As AcadEntity


Dim i As Integer
Dim j As Integer
Dim s As Integer
Dim Plobj As AcadPolyline
Dim coor As Variant
Dim coords As Variant
Dim pnt As Variant
Dim Sset As AcadSelectionSet




'clearsset

Set Sset = ThisDrawing.SelectionSets.Add("GD")

ThisDrawing.Utility.GetEntity ent, pnt, "c"

coords = ent.Coordinates


Sset.SelectByPolygon acSelectionSetWindowPolygon, coords
Debug.Print Sset.Count
'Sset.Delete
Set Outer(0) = ent '定义填充外边界

Set hatchObj = ThisDrawing.ModelSpace.AddHatch(Ptype, Pname, Ba)
'Hatchobj.HatchStyle = acHatchStyleOuter
hatchObj.AppendOuterLoop (Outer)

Dim K As Integer


Dim Inner(0 To 0) As AcadEntity



For K = 0 To Sset.Count - 1


    Set Inner(0) = Sset.Item(K)
hatchObj.AppendInnerLoop (Inner)

Next






'hatchObj.Evaluate

Sset.Delete
ThisDrawing.Regen True


End Sub