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

nhy12345678

我们经常需要填充不同的填充图案，每次输入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

解决了！一起分享下！

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