社区 › VB › [求助]各位大虾：可以用VBA对已有的图形实现自动填充吗？

enderxu 发表于 2008-7-25 15:49:00

[求助]各位大虾：可以用VBA对已有的图形实现自动填充吗？

我知道在模型空间里，用绘图菜单的图案填充可以选择一个对象很方便的进行图案填充。我也知道在VBA里可以用HATCH，加上outerloop和innerloop就可以创建填充的图形。我的问题是：既然在模型空间里有这么方便的实现填充的方法，那么有没有相应的VBA语句可以同样的实现呢？

enderxu 发表于 2008-7-25 15:55:00

自己顶一下！请有经验的各位帮帮忙哈，在网上和书上查无所获希望能在这里聆听教诲

enderxu 发表于 2008-7-25 16:24:00

在线等啊，请高手帮忙

wylong 发表于 2008-7-25 21:27:00

Sub TestHatch()
    '外边界和内边界
    Dim OuterLoop(0) As Object 'AcadEntity
    Dim innerLoop(0) As Object 'AcadEntity
   
    ' 为填充创建外边界边界
    Set OuterLoop(0) = CreateCircle
   
    ' 为填充创建内边界边界
    Set innerLoop(0) = CreateCircle(2.5)
   
    Dim HatchObj As Object
    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)
      
    HatchObj.AppendOuterLoop (OuterLoop)
    HatchObj.AppendInnerLoop (innerLoop)
      
    HatchObj.PatternScale = 0.25
    HatchObj.Lineweight = acLnWtByLwDefault
    HatchObj.Color = acByBlock
    HatchObj.Evaluate
End Sub
' 创建圆
Public Function CreateCircle(Optional Radius As Double = 3) As Object 'AcadCircle
    Dim ptBase(0 To 2) As Double
    ptBase(0) = 0: ptBase(1) = 0: ptBase(2) = 0
    Set CreateCircle = ThisDrawing.ModelSpace.AddCircle(ptBase, Radius)
End Function

enderxu 发表于 2008-7-26 12:33:00

谢谢wylong！
不过您这个方法还是用的是外界和内界的hatch 方法。我的问题是：是不是用VBA填空只有这种方法了？有没有利用已有图形，像在模型界面一样，直接填充的方法？
不管怎么样，谢谢您。

sailorcwx 发表于 2008-7-26 12:57:00

Sub test()
Dim pl As AcadEntity
Dim pt As Variant
ThisDrawing.Utility.GetEntity pl, pt
Dim ht As AcadHatch
Set ht = ThisDrawing.ModelSpace.AddHatch(acHatchObject, "solid", True)
Dim ot(0) As AcadEntity
Set ot(0) = pl
ht.AppendOuterLoop (ot)
End Sub

兰州人 发表于 2008-7-30 09:41:00

此种方法简单实用，奖励。

查看完整版本: [求助]各位大虾：可以用VBA对已有的图形实现自动填充吗？