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

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

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

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

解决了！一起分享下！
Public Sub qt() '快速填充
On Error GoTo err
Dim hatchObj As AcadHatch
Dim patternName As String
Dim PatternType As Long
Dim bAssociativity As Boolean
Dim outerLoop(0) As AcadEntity ' 定义图案填充
patternName = "ANSI31"
PatternType = 0
bAssociativity = True
Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity) ' 当前图纸的实体数目
Dim n As Long
n = ThisDrawing.ModelSpace.Count ' 调用BOUNDARY命令获取某一点处的边界
Dim Pt As Variant
Pt = ThisDrawing.Utility.GetPoint(, "指定内部点: ")
ThisDrawing.SendCommand "_-Boundary" & vbCr & Pt(0) & "," & Pt(1) & vbCr & vbCr ' 如果存在边界，则会生成新的实体
If ThisDrawing.ModelSpace.Count > n Then
      Set outerLoop(0) = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1)
Else
      MsgBox "未发现有效的边界。"
      GoTo err
End If
hatchObj.AppendOuterLoop outerLoop ' 计算并显示图案填充
hatchObj.Evaluate
ThisDrawing.Regen True
outerLoop(0).Delete
ThisDrawing.Regen True
err:
End Sub

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

发表回复

精选推荐