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

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

我知道在模型空间里，用绘图菜单的图案填充可以选择一个对象很方便的进行图案填充。我也知道在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对已有的图形实现自动填充吗？

发表回复

精选推荐