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

本帖最后由 作者 于 2008-7-25 21:27:45 编辑 <br /><br /> <p>Sub TestHatch()<br/>&nbsp;&nbsp;&nbsp; '外边界和内边界<br/>&nbsp;&nbsp;&nbsp; Dim OuterLoop(0) As Object 'AcadEntity<br/>&nbsp;&nbsp;&nbsp; Dim innerLoop(0) As Object 'AcadEntity<br/>&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp; ' 为填充创建外边界边界<br/>&nbsp;&nbsp;&nbsp; Set OuterLoop(0) = CreateCircle<br/>&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp; ' 为填充创建内边界边界<br/>&nbsp;&nbsp;&nbsp; Set innerLoop(0) = CreateCircle(2.5)<br/>&nbsp;&nbsp;&nbsp;&nbsp;<br/>&nbsp;&nbsp;&nbsp; Dim HatchObj As Object<br/>&nbsp;&nbsp;&nbsp; Dim PatternName As String<br/>&nbsp;&nbsp;&nbsp; Dim PatternType As Long<br/>&nbsp;&nbsp;&nbsp; Dim bAssociativity As Boolean<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp; ' 定义填充<br/>&nbsp;&nbsp;&nbsp; PatternName = "ANSI31"<br/>&nbsp;&nbsp;&nbsp; PatternType = 0<br/>&nbsp;&nbsp;&nbsp; bAssociativity = True<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp; ' 在模型空间中创建关联填充<br/>&nbsp;&nbsp;&nbsp; Set HatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, PatternName, bAssociativity)<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp; HatchObj.AppendOuterLoop (OuterLoop)<br/>&nbsp;&nbsp;&nbsp; HatchObj.AppendInnerLoop (innerLoop)<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<br/>&nbsp;&nbsp;&nbsp; HatchObj.PatternScale = 0.25<br/>&nbsp;&nbsp;&nbsp; HatchObj.Lineweight = acLnWtByLwDefault<br/>&nbsp;&nbsp;&nbsp; HatchObj.Color = acByBlock<br/>&nbsp;&nbsp;&nbsp; HatchObj.Evaluate</p><p>End Sub</p><p>' 创建圆<br/>Public Function CreateCircle(Optional Radius As Double = 3) As Object 'AcadCircle<br/>&nbsp;&nbsp;&nbsp; Dim ptBase(0 To 2) As Double<br/>&nbsp;&nbsp;&nbsp; ptBase(0) = 0: ptBase(1) = 0: ptBase(2) = 0<br/>&nbsp;&nbsp;&nbsp; Set CreateCircle = ThisDrawing.ModelSpace.AddCircle(ptBase, Radius)<br/>End Function</p>

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

<p>谢谢<strong><font face="Verdana" color="#61b713">wylong！</font></strong></p><p><strong><font face="Verdana" color="#61b713">不过您这个方法还是用的是外界和内界的hatch&nbsp;方法。我的问题是：是不是用VBA填空只有这种方法了？有没有利用已有图形，像在模型界面一样，直接填充的方法？</font></strong></p><p><strong><font face="Verdana" color="#61b713">不管怎么样，谢谢您。</font></strong></p>

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

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

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

sailorcwx发表于2008-7-26 12:57:00static/image/common/back.gifSub test()Dim pl As AcadEntityDim pt As VariantThisDrawing.Utility.GetEntity pl, ptDim ht As AcadHatchSet ht = ThisDrawing.ModelSpace.AddHatch(acHatchObject, \"solid\", True)Dim o

<p>此种方法简单实用，奖励。</p>
页: [1]
查看完整版本: [求助]各位大虾：可以用VBA对已有的图形实现自动填充吗？