VBA 如何实现点选模式的填充呢？
我们经常需要填充不同的填充图案，每次输入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
这中间代码怎么写呢？
解决了！一起分享下！
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
页:
[1]