nhy12345678 发表于 2008-5-9 17:53:00

VBA 如何实现点选模式的填充呢？

本帖最后由 作者 于 2008-5-9 17:55:08 编辑 <br /><br /> <p>我们经常需要填充不同的填充图案，每次输入H命令后都要去调整填充样式，比例，角度等很麻烦，最近研究了下VBA可以自动设置需要的填充，采用不同的命令直接填充不同的填充样式，其中就遇到如何实现象H命令的点选填充那样确定填充范围。如果不行的话能否用VBA改变当前填充设置中的样式。</p><p>Sub jmg()<br/>On Error GoTo err<br/>&nbsp;&nbsp;&nbsp; Dim hatchObj As AcadHatch<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; ' 定义和创建图案填充<br/>&nbsp;&nbsp;&nbsp; patternName = "cork"<br/>&nbsp;&nbsp;&nbsp; PatternType = 0<br/>&nbsp;&nbsp;&nbsp; bAssociativity = True<br/>&nbsp;&nbsp;&nbsp; Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)<br/>&nbsp;&nbsp;&nbsp; hatchObj.PatternScale = 4<br/>&nbsp;&nbsp;&nbsp; hatchObj.PatternAngle = 0.7853981 '90度<br/>&nbsp;&nbsp;&nbsp;&nbsp;'----------------------------------------------这里代码怎么写呢？<br/>&nbsp;&nbsp;&nbsp; hatchObj.Evaluate<br/>&nbsp;&nbsp;&nbsp; ThisDrawing.Regen True<br/>err:</p><p>End Sub</p><p></p><p>这中间代码怎么写呢？</p>

nhy12345678 发表于 2008-5-14 15:11:00

本帖最后由 作者 于 2008-5-14 15:12:31 编辑 <br /><br /> <p>解决了！一起分享下！</p><p>Public Sub qt() '快速填充<br/>&nbsp;&nbsp;&nbsp; On Error GoTo err<br/>&nbsp;&nbsp;&nbsp; Dim hatchObj As AcadHatch<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; Dim outerLoop(0) As AcadEntity&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; Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)&nbsp;&nbsp; ' 当前图纸的实体数目<br/>&nbsp;&nbsp;&nbsp; Dim n As Long<br/>&nbsp;&nbsp;&nbsp; n = ThisDrawing.ModelSpace.Count&nbsp;&nbsp;&nbsp; ' 调用BOUNDARY命令获取某一点处的边界<br/>&nbsp;&nbsp;&nbsp; Dim Pt As Variant<br/>&nbsp;&nbsp;&nbsp; Pt = ThisDrawing.Utility.GetPoint(, "指定内部点: ")<br/>&nbsp;&nbsp;&nbsp; ThisDrawing.SendCommand "_-Boundary" &amp; vbCr &amp; Pt(0) &amp; "," &amp; Pt(1) &amp; vbCr &amp; vbCr&nbsp;&nbsp;&nbsp; ' 如果存在边界，则会生成新的实体<br/>&nbsp;&nbsp; If ThisDrawing.ModelSpace.Count &gt; n Then<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Set outerLoop(0) = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1)<br/>&nbsp;&nbsp;&nbsp; Else<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; MsgBox "未发现有效的边界。"<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; GoTo err<br/>&nbsp;&nbsp;&nbsp; End If<br/>&nbsp;&nbsp;&nbsp; hatchObj.AppendOuterLoop outerLoop&nbsp;&nbsp;&nbsp; ' 计算并显示图案填充<br/>&nbsp;&nbsp;&nbsp; hatchObj.Evaluate<br/>&nbsp;&nbsp;&nbsp; ThisDrawing.Regen True<br/>outerLoop(0).Delete<br/>ThisDrawing.Regen True<br/>err:<br/>End Sub</p>
页: [1]
查看完整版本: VBA 如何实现点选模式的填充呢？