自动填充的，出错了，帮忙看看！！

home

Sub test()
    Dim hatchObj As AcadHatch
    Dim patternName As String
    Dim PatternType As Long
    Dim bAssociativity As Boolean
    Dim outerLoop(0 To 0) As AcadEntity

    ' 定义图案填充
    patternName = "ANSI31"
    PatternType = 0
    bAssociativity = True

    ' 当前图纸的实体数目
    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
   
    ' 如果存在边界，则会生成新的实体
    Dim lwpLineObj As AcadLWPolyline
    If ThisDrawing.ModelSpace.Count > n Then
        Set lwpLineObj = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1)
        MsgBox lwpLineObj.Area
'        lwpLineObj.Delete
        lwpLineObj.Closed = True
    Else
        MsgBox "未发现有效的边界。"
    End If
    outerLoop(0) = lwpLineObj
    hatchObj.AppendOuterLoop (outerLoop)
    hatchObj.Evaluate
    ObjDoc.Regen True
End Sub

home

解决了，

需要加Boundary命令前加个zoomall命令

muzi2005888

我想楼主个问题

在对面域填充时

当面域为不连续或为环状时则不能正常填充（利用快速选择能选中图案填充，就是不能显示）

nhy12345678

Dim i As Long
Dim hatchObj As AcadHatch
Dim patternName As String
Dim patternType As Long
Dim assocVar As Boolean
Dim outerLoop(0 To 0) As AcadEntity
Dim eNt As AcadEntity
Dim sset As AcadSelectionSet
Dim outerLoop1(0 To 0) As AcadEntity
Dim n As Long
Dim Pt As Variant
patternName = "SOLID"
patternType = acHatchPatternTypePreDefined
assocVar = True
n = ThisDrawing.ModelSpace.Count
Pt = ThisDrawing.Utility.GetPoint(, "指定内部点: ")
ThisDrawing.SendCommand "_-Boundary" & vbCr & Pt(0) & "," & Pt(1) & vbCr & vbCr
If ThisDrawing.ModelSpace.Count > n Then
   Set outerLoop1(0) = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1)
Else
   MsgBox "未发现有效的边界。"
End If
 Set sset = ThisDrawing.SelectionSets.Add("ss7")
 sset.AddItems outerLoop1
For Each eNt In sset
   Set outerLoop(0) = eNt
   Set hatchObj = ThisDrawing.ModelSpace.AddHatch(patternType, patternName, assocVar)
   hatchObj.AppendOuterLoop (outerLoop)
   hatchObj.Evaluate
Next
sset.Delete
ThisDrawing.Regen True