[原创]：TlsBoundary类,专用于在块内按点生成填充

雪山飞狐(lzh)

'TlsBoundary类,专用于在块内按点生成填充
'编制:天龙工作室

' You may use the code included in this module in any way,
' provided that both the above copyright notice and the
' release of liability (stated below) appear in all copies.

Private pExplodeObjs As Collection
Private pOwner As AcadBlock
Private pBlock As AcadBlock
Private pRegions As Variant
Private OuterLoop As AcadRegion
Private InnerLoop As AcadRegion

Private Sub Class_Initialize()
    Set pBlock = ThisDrawing.ModelSpace
End Sub

Private Sub Class_Terminate()
On Error Resume Next
    pBlock.Delete
End Sub

Public Property Let Owner(ByVal Value As AcadBlock)
'边界所有者
    Dim pnt(2) As Double
    Set pOwner = Value
    Set pBlock = ThisDrawing.Blocks.Add(pnt, "*U")
    pBlock.InsertBlock pnt, Value.Name, 1, 1, 1, 0
End Property

Public Property Let WorkSpace(ByVal Value As AcadBlock)
'工作空间
On Error Resume Next
    Set pOwner = Nothing
    pBlock.Delete
    Set pBlock = Value
End Property

Private function CanBeExploded() As Boolean
'判断各图元是否可被炸开
On Error Resume Next
    Dim i As AcadEntity
    Set pExplodeObjs = New Collection
    For Each i In pBlock
        If _
            i.ObjectName <> "AcDbLine" And _
            i.ObjectName <> "AcDbCircle" And _
            i.ObjectName <> "AcDbArc" And _
            i.ObjectName <> "AcDbEllipse" _
        Then
            pExplodeObjs.Add i
            CanBeExploded = True
        End If
    Next i
End Function

Private Sub Explode()
'将所有图元炸开为基本图元
On Error Resume Next
Dim i As AcadEntity
    Do While CanBeExploded
        For Each i In pExplodeObjs
            i.Explode
            If Err Then Err.Clear
            i.Delete
        Next i
    Loop
End Sub

Private Sub SortValue(ByRef Values As Variant, ByVal Count As Integer)
'值排序
    Dim pTemp As Double
    For i = Count To 1 Step -1
        For j = 0 To i - 1
            If Values(j) > Values(j + 1) Then
                pTemp = Values(j + 1)
                Values(j + 1) = Values(j)
                Values(j) = pTemp
            End If
        Next j
    Next i
End Sub

Private Sub SortPoint(ByRef Values As Variant, ByRef Points As Variant, ByVal Count As Integer)
'按值将点数组排序
    Dim pTemp As Double, pnt As Variant
    For i = Count To 1 Step -1
        For j = 0 To i - 1
            If Values(j) > Values(j + 1) Then
                pTemp = Values(j + 1)
                Values(j + 1) = Values(j)
                Values(j) = pTemp
                pnt = Points(j + 1)
                Points(j + 1) = Points(j)
                Points(j) = pnt
            End If
        Next j
    Next i
End Sub

Public function GetIntersection(TlsObject As AcadEntity, Optional Count)
'获取图元的全部交点
    Dim pnts(), dot
    Dim pnt(2) As Double
    Dim n As Integer
    Dim i
    Dim pNum As Integer
    If IsMissing(Count) Then Count = pBlock.Count
    For i = 0 To Count - 1
        If Not (TlsObject Is pBlock(i)) Then
            dot = TlsObject.IntersectWith(pBlock(i), acExtendNone)
            n = (UBound(dot) + 1) / 3
            For j = 0 To n - 1
                pnt(0) = dot(j * 3)
                pnt(1) = dot(j * 3 + 1)
                ReDim Preserve pnts(pNum)
                pnts(pNum) = pnt
                pNum = pNum + 1
            Next j
        End If
    Next i
    If pNum = 0 Then
        GetIntersection = False
    Else
        GetIntersection = pnts
    End If
End Function


Public function BreakLineAtPoint(ByVal TlsLine As AcadEntity, ByVal Points As Variant)
'按点打断直线
    Dim pStart, PEnd
    Dim pNum As Integer
    Dim pCount As Integer
    Dim pDistances() As Double
    pStart = TlsLine.StartPoint
    PEnd = TlsLine.EndPoint
    pCount = UBound(Points)
    ReDim pDistances(pCount) As Double
    If TlsLine.Angle = 0 Or TlsLine.Angle = Atn(1) * 4 Then pNum = 0 Else pNum = 1
    For i = 0 To pCount
        pDistances(i) = Abs(Points(i)(pNum) - pStart(pNum))
    Next i
    SortPoint pDistances, Points, pCount
    If Abs(pDistances(0)) > 10 ^ -8 Then pBlock.AddLine pStart, Points(0)
    For i = 0 To pCount - 1
        If Abs(pDistances(i) - pDistances(i + 1)) > 10 ^ -8 Then pBlock.AddLine Points(i), Points(i + 1)
    Next i
    If Abs(Points(pCount)(pNum) - PEnd(pNum)) > 10 ^ -8 Then pBlock.AddLine Points(pCount), PEnd
End Function

Public function BreakArcAtPoint(TlsArc As AcadEntity, Points As Variant)
'按点打断圆弧
    Dim pStart As Variant, PEnd As Variant
    Dim pCount As Integer
    Dim pAngles() As Double
    Dim pRadius As Double, pCenter
    pStart = TlsArc.StartAngle
    PEnd = TlsArc.EndAngle
    pRadius = TlsArc.radius
    pCenter = TlsArc.Center
    pCount = UBound(Points)
    ReDim pAngles(pCount) As Double
    For i = 0 To pCount
        pAngles(i) = ThisDrawing.Utility.AngleFromXAxis(pCenter, Points(i))
        If pStart > PEnd And pAngles(i) < PEnd Then pAngles(i) = pAngles(i) + Atn(1) * 8
    Next i
    SortValue pAngles, pCount
    If pAngles(0) <> 0 Then pBlock.AddArc pCenter, pRadius, pStart, pAngles(0)
    For i = 0 To pCount - 1
        If pAngles(i) <> pAngles(i + 1) Then pBlock.AddArc pCenter, pRadius, pAngles(i), pAngles(i + 1)
    Next i
    If pAngles(pCount) <> PEnd Then pBlock.AddArc pCenter, pRadius, pAngles(pCount), PEnd
End Function

Public function BreakCircleAtPoint(TlsCircle As AcadEntity, Points As Variant)
'按点打断圆
    Dim pCount As Integer
    Dim pAngles() As Double
    Dim pRadius As Double, pCenter
    pRadius = TlsCircle.radius
    pCenter = TlsCircle.Center
    pCount = UBound(Points)
    ReDim pAngles(pCount) As Double
    For i = 0 To pCount
        pAngles(i) = ThisDrawing.Utility.AngleFromXAxis(pCenter, Points(i))
    Next i
    SortValue pAngles, pCount
    For i = 0 To pCount - 1
        If pAngles(i) <> pAngles(i + 1) Then pBlock.AddArc pCenter, pRadius, pAngles(i), pAngles(i + 1)
    Next i
        If pAngles(pCount) <> pAngles(0) Then pBlock.AddArc pCenter, pRadius, pAngles(pCount), pAngles(0)
End Function

Public function BreakEllipseAtPoint(ByVal TlsEllipse As AcadEntity, ByVal Points As Variant)
'按点打断椭圆
    Dim pCount As Integer
    Dim pAngles() As Double
    Dim pRadius As Double, pCenter, pMajorAxis
    Dim pEllipse As AcadEllipse
    Dim pAngle As Double
    Dim pLine As AcadLine
    Dim pnt(2) As Double
    pStart = TlsEllipse.StartAngle
    PEnd = TlsEllipse.EndAngle
    pRadius = TlsEllipse.RadiusRatio
    pCenter = TlsEllipse.Center
    pMajorAxis = TlsEllipse.MajorAxis
    pCount = UBound(Points)
    Set pLine = pBlock.AddLine(pnt, pMajorAxis)
    pAngle = pLine.Angle
    pLine.Delete
    ReDim pAngles(pCount) As Double
    For i = 0 To pCount
        pAngles(i) = ThisDrawing.Utility.AngleFromXAxis(pCenter, Points(i)) - pAngle
        If pAngles(i) < 0 Then pAngles(i) = pAngles(i) + Atn(1) * 8
        If pStart > PEnd And pAngles(i) < PEnd Then pAngles(i) = pAngles(i) + Atn(1) * 8
    Next i
    SortValue pAngles, pCount
    For i = 0 To pCount - 1
        If pAngles(i) <> pAngles(i + 1) Then
            Set pEllipse = pBlock.AddEllipse(pCenter, pMajorAxis, pRadius)
            pEllipse.StartAngle = pAngles(i)
            pEllipse.EndAngle = pAngles(i + 1)
        End If
    Next i
    If PEnd - pStart = Atn(1) * 8 Then
        If pAngles(pCount) <> pAngles(0) Then
            Set pEllipse = pBlock.AddEllipse(pCenter, pMajorAxis, pRadius)
            pEllipse.StartAngle = pAngles(pCount)
            pEllipse.EndAngle = pAngles(0)
        End If
    Else
        If pStart <> pAngles(0) Then
            Set pEllipse = pBlock.AddEllipse(pCenter, pMajorAxis, pRadius)
            pEllipse.StartAngle = pStart
            pEllipse.EndAngle = pAngles(0)
        End If
        If PEnd <> pAngles(pCount) Then
            Set pEllipse = pBlock.AddEllipse(pCenter, pMajorAxis, pRadius)
            pEllipse.StartAngle = pAngles(pCount)
            pEllipse.EndAngle = PEnd
        End If
    End If
End Function

Private Sub BreakAllAtPoint()
'按交点打断所有图元
    Dim pCount As Integer
    Dim i As Integer
    Dim pnts As Variant
    Dim pObjs(0) As AcadEntity
    Explode
    pCount = pBlock.Count
    For i = 0 To pCount - 1
        pnts = GetIntersection(pBlock(i), pCount)
        If Not IsArray(pnts) Then
            Set pObjs(0) = pBlock(i)
            ThisDrawing.CopyObjects (pObjs)
        Else
            If pBlock(i).ObjectName = "AcDbLine" Then
                BreakLineAtPoint pBlock(i), pnts
            ElseIf pBlock(i).ObjectName = "AcDbCircle" Then
                BreakCircleAtPoint pBlock(i), pnts
            ElseIf pBlock(i).ObjectName = "AcDbArc" Then
                BreakArcAtPoint pBlock(i), pnts
            ElseIf pBlock(i).ObjectName = "AcDbEllipse" Then
                BreakEllipseAtPoint pBlock(i), pnts
            End If
        End If
    Next i
    For i = 0 To pCount - 1
        pBlock(0).Delete
    Next i
End Sub

Public Sub CreateRegions()
'创建面域
    Dim pObjs() As AcadEntity
    If pOwner Is Nothing Then Exit Sub
    BreakAllAtPoint
    ReDim pObjs(pBlock.Count - 1) As AcadEntity
    For i = 0 To pBlock.Count - 1
        Set pObjs(i) = pBlock(i)
    Next i
On Error Resume Next
    pRegions = pBlock.AddRegion(pObjs)
End Sub

Public function PointInRegion(ByVal TlsRegion, ByVal Point) As Boolean
'判断点是否在面域内
    Dim pCopy As AcadRegion, pRegion As AcadRegion
    Dim pObjs(0) As AcadEntity
    Set pCopy = TlsRegion.Copy
    Set pObjs(0) = pBlock.AddCircle(Point, 0.0001)
    Set pRegion = pBlock.AddRegion(pObjs)(0)
    pRegion.Boolean acIntersection, pCopy
    If pRegion.Area > 0 Then PointInRegion = True
    pRegion.Delete
    pObjs(0).Delete
End Function

Public function InRegion(ByVal TlsRegion, ByVal SubRegion) As Boolean
'判断面域是否在面域内
    Dim pCopy As AcadRegion, pRegion As AcadRegion
    Dim pArea As Double
    Set pCopy = TlsRegion.Copy
    Set pRegion = SubRegion.Copy
    pArea = pRegion.Area
    pRegion.Boolean acIntersection, pCopy
    If pRegion.Area = pArea Then InRegion = True
    pRegion.Delete
End Function

Private function CreateLoop(Point As Variant) As Integer
'创建边界
On Error Resume Next
    Dim i As Integer, j As AcadEntity
    Dim m As Integer, n As Integer
    Dim pObjs(0) As AcadEntity
    Dim pRegion As AcadRegion
    Dim pArea As Double
    Dim pJudge As Boolean
    Dim pCount As Integer
    For i = 0 To UBound(pRegions)
        If PointInRegion(pRegions(i), Point) Then
            pJudge = True
            If pArea <> 0 Then
                If pArea > pRegions(i).Area Then
                    pArea = pRegions(i).Area
                    n = i
                End If
            Else
                pArea = pRegions(i).Area
                n = i
            End If
        End If
    Next i
    CreateLoop = 0
    If pJudge Then
        CreateLoop = 1
        Set pObjs(0) = pRegions(n)
        ThisDrawing.CopyObjects pObjs, pOwner
        Set OuterLoop = pOwner(pOwner.Count - 1)
        m = 0
        For i = 0 To UBound(pRegions)
            If i <> n Then
                If InRegion(pRegions(n), pRegions(i)) Then
                    CreateLoop = 2
                    If m = 0 Then
                        Set pRegion = pRegions(i).Copy
                    Else
                        pRegion.Boolean acUnion, pRegions(i).Copy
                    End If
                    m = m + 1
                End If
            End If
        Next i
        If CreateLoop = 2 Then
            Set pObjs(0) = pRegion
            ThisDrawing.CopyObjects pObjs, pOwner
            Set InnerLoop = pOwner(pOwner.Count - 1)
            pRegion.Delete
        End If
    End If
End Function

Public function CreateHatch(ByVal Point As Variant, ByVal PatternName As String, Optional PatternScale As Double = 1, Optional PatternAngle As Double = 0) As AcadHatch
'创建填充
On Error Resume Next
    Dim i As Integer
    Dim pHatch As AcadHatch
    Dim pJudge As Integer
    Dim pObjs(0) As AcadEntity
    Dim pInObjs As Variant
    If pOwner Is Nothing Then Exit Function
    pJudge = CreateLoop(Point)
    If pJudge > 0 Then
        Set pHatch = pOwner.AddHatch(0, PatternName, False)
        Set pObjs(0) = OuterLoop
        pHatch.AppendOuterLoop pObjs
        If pJudge = 2 Then
            pInObjs = InnerLoop.Explode
            If pInObjs(0).ObjectName = "AcDbRegion" Then
                For i = 0 To UBound(pInObjs)
                    Set pObjs(0) = pInObjs(i)
                    pHatch.AppendInnerLoop pObjs
                Next i
            Else
                    Set pObjs(0) = InnerLoop
                    pHatch.AppendInnerLoop pObjs
            End If
        End If
        pHatch.PatternScale = PatternScale
        pHatch.PatternAngle = PatternAngle / 45 * Atn(1)
        pHatch.Evaluate
    End If
    OuterLoop.Delete
    InnerLoop.Delete
    For i = 0 To UBound(pInRegions)
        pInRegions(i).Delete
    Next i
    For i = 0 To UBound(pInObjs)
        pInObjs(i).Delete
    Next i
    Set CreateHatch = pHatch
End Function

其中Break???AtPoint、PointInRegion和InRegion函数可单独使用


下面两个例子说明如何使用

Sub Sample_TlsBoundary()
    Dim pBlock As AcadBlock, pObj As AcadBlockReference
    Dim a As New TlsBoundary
    Dim pnt(2) As Double
    Dim p1(2) As Double, p2(2) As Double, p3(2) As Double, p4(2) As Double
    Set pBlock = ThisDrawing.Blocks.Add(pnt, "*U")
    p2(0) = 10: p3(1) = 10
    p4(0) = 3: p4(1) = 3
    pBlock.AddLine(p1, p2).Layer = "01"
    pBlock.AddLine(p1, p3).Layer = "01"
    pBlock.AddLine(p2, p3).Layer = "01"
    pBlock.AddCircle(p1, 1).Layer = "01"
    pBlock.AddCircle(p2, 1).Layer = "01"
    pBlock.AddCircle(p3, 1).Layer = "01"
    pBlock.AddCircle(p4, 1).Layer = "01"
    pnt(0) = 2: pnt(1) = 2
    a.Owner = pBlock
    a.CreateRegions
    a.CreateHatch(pnt, "ansi31", 0.5).Layer = "02"
    a.CreateHatch(p4, "ansi31", 0.1, 90).Layer = "02"
    p1(0) = -0.5
    a.CreateHatch(p1, "ansi31", 0.1, 30).Layer = "02"
    p2(0) = p2(0) + 0.5
    a.CreateHatch(p2, "ansi31", 0.1, 60).Layer = "02"
    p3(1) = p3(1) + 0.5
    a.CreateHatch(p3, "ansi31", 0.1, 90).Layer = "02"
    Set pObj = ThisDrawing.ModelSpace.InsertBlock(ThisDrawing.Utility.GetPoint(, vbCrLf & "请输入插入点"), pBlock.Name, 1, 1, 1, 0)
End Sub


Sub Sample_TlsBoundary_Break()
    Dim a As New TlsBoundary
    Dim b As AcadEntity
    Dim pnts As Variant
    Set b = ThisDrawing.ModelSpace(0)
    pnts = a.GetIntersection(b)
    If IsArray(pnts) Then
    a.BreakArcAtPoint b, pnts
    b.Delete
    End If
End Sub

随缘OK

您的这个东东如何使用？给个实例文件好吗？谢谢

雪山飞狐(lzh)

这个的版本老了一点，贴个新一点的吧
[Code]
'TlsBoundary类,专用于在块内按点生成填充
'编制:天龙工作室

' You may use the code included in this module in any way,
' provided that both the above copyright notice and the
' release of liability (stated below) appear in all copies.
Private pSouce As Object
Private pBlock As AcadBlock
Private pWorkSpace As AcadObject
Private pRegions As Variant
Private OuterLoop As AcadRegion
Private InnerLoop As AcadRegion

Private Sub Class_Terminate()
On Error Resume Next
   
    pWorkSpace.Delete
   
End Sub

Private Function IsEqual(ByVal Value1 As Double, ByVal Value2 As Double) As Boolean

    IsEqual = Abs(Value1 - Value2) < 10 ^ -8
   
End Function

Public Property Let Owner(ByVal Value As AcadBlock)
'边界所有者
    Dim pnt(2) As Double
   
    Set pBlock = Value
    Set pWorkSpace = ThisDrawing.Blocks.Add(pnt, "*U")
    Set pSouce = pWorkSpace
    pWorkSpace.InsertBlock pnt, Value.Name, 1, 1, 1, 0
End Property

Public Property Let WorkSpace(ByVal Value As Object)
'工作空间
On Error Resume Next
   
    Set pBlock = Nothing
    pWorkSpace.Delete
    Err.Clear
   
    Set pSouce = Value
   
    If TypeOf Value Is AcadBlock Then
        Set pWorkSpace = Value
    ElseIf TypeOf Value Is AcadSelectionSet Then
        Set pWorkSpace = ThisDrawing.ModelSpace
    End If
   
End Property

Public Sub Explode()
'将所有图元炸开为基本图元
On Error Resume Next
    Dim pCanBeExploded As Boolean
    Dim i As AcadEntity
   
    pCanBeExploded = True
   
    Do While pCanBeExploded
   
        pCanBeExploded = False
        
        For Each i In pWorkSpace
        
            If _
                i.ObjectName <> "AcDbLine" And _
                i.ObjectName <> "AcDbCircle" And _
                i.ObjectName <> "AcDbArc" And _
                i.ObjectName <> "AcDbEllipse" _
            Then
                i.Explode
                Err.Clear
                i.Delete
                pCanBeExploded = True
            End If
            
        Next i
        
    Loop
   
End Sub

Private Sub SortValue(ByRef Values As Variant, ByVal Count As Integer)
'值排序
    Dim pTemp As Double
   
    For i = Count To 1 Step -1
   
        For j = 0 To i - 1
        
            If Values(j) > Values(j + 1) Then
                pTemp = Values(j + 1)
                Values(j + 1) = Values(j)
                Values(j) = pTemp
            End If
            
        Next j
        
    Next i
End Sub

Private Sub SortPoint(ByRef Values As Variant, ByRef points As Variant, ByVal Count As Integer)
'按值将点数组排序
    Dim pTemp As Double, pnt As Variant
   
    For i = Count To 1 Step -1
   
        For j = 0 To i - 1
        
            If Values(j) > Values(j + 1) Then
                pTemp = Values(j + 1)
                Values(j + 1) = Values(j)
                Values(j) = pTemp
                pnt = points(j + 1)
                points(j + 1) = points(j)
                points(j) = pnt
            End If
            
        Next j
        
    Next i
   
End Sub

Private Function GetIntersection(ByVal TlsObject As AcadEntity, Optional ByVal Count)
'获取图元的全部交点
    Dim pnts(), dot
    Dim pnt(2) As Double
    Dim n As Integer
    Dim i, j
    Dim pNum As Integer
   
    If IsMissing(Count) Then Count = pSouce.Count
   
    For i = 0 To Count - 1
   
        If Not (TlsObject Is pSouce(i)) Then
        
            dot = TlsObject.IntersectWith(pSouce(i), acExtendNone)
            n = (UBound(dot) + 1) / 3
            For j = 0 To n - 1
                pnt(0) = dot(j * 3)
                pnt(1) = dot(j * 3 + 1)
                ReDim Preserve pnts(pNum)
                pnts(pNum) = pnt
                pNum = pNum + 1
            Next j
            
        End If
        
    Next i
   
    If pNum = 0 Then
        GetIntersection = False
    ElseIf pNum = 1 Then
        If TlsObject.ObjectName = "AcDbLine" Then
            GetIntersection = pnts
        ElseIf TlsObject.ObjectName = "AcDbCircle" Then
            GetIntersection = False
        ElseIf Abs(TlsObject.EndAngle - TlsObject.StartAngle - Atn(1) * 8) > 10 ^ -8 Then
            GetIntersection = False
        Else
            GetIntersection = pnts
        End If
    Else
        GetIntersection = pnts
    End If
   
End Function


Private Function BreakLineAtPoint(ByVal TlsLine As AcadEntity, ByVal points)
'按点打断直线
    Dim pStart, pEnd
    Dim pNum As Integer
    Dim pCount As Integer
    Dim pDistances() As Double
   
    pStart = TlsLine.StartPoint
    pEnd = TlsLine.EndPoint
    pCount = UBound(points)
   
    If Abs(Tan(TlsLine.Angle)) < 1 Then pNum = 0 Else pNum = 1
   
    ReDim pDistances(pCount) As Double
    For i = 0 To pCount
        pDistances(i) = Abs(points(i)(pNum) - pStart(pNum))
    Next i
   
    SortPoint pDistances, points, pCount
   
    If Not IsEqual(pDistances(0), 0) Then pWorkSpace.AddLine pStart, points(0)
   
    For i = 0 To pCount - 1
        If Not IsEqual(pDistances(i), pDistances(i + 1)) Then pWorkSpace.AddLine points(i), points(i + 1)
    Next i
   
    If Not IsEqual(points(pCount)(pNum), pEnd(pNum)) Then pWorkSpace.AddLine points(pCount), pEnd
   
End Function

Private Function BreakArcAtPoint(ByVal TlsArc As AcadEntity, ByVal points)
'按点打断圆弧
    Dim pStart As Variant, pEnd As Variant
    Dim pCount As Integer
    Dim pAngles() As Double
    Dim pRadius As Double, pCenter
   
    pStart = TlsArc.StartAngle
    pEnd = TlsArc.EndAngle
    pRadius = TlsArc.radius
    pCenter = TlsArc.Center
    pCount = UBound(points)
   
    ReDim pAngles(pCount) As Double
    For i = 0 To pCount
        pAngles(i) = ThisDrawing.Utility.AngleFromXAxis(pCenter, points(i))
        If pStart > pEnd And pAngles(i) < pEnd Then pAngles(i) = pAngles(i) + Atn(1) * 8
    Next i
   
    SortValue pAngles, pCount
   
    If Not IsEqual(pAngles(0), 0) Then pWorkSpace.AddArc pCenter, pRadius, pStart, pAngles(0)
   
    For i = 0 To pCount - 1
        If Not IsEqual(pAngles(i), pAngles(i + 1)) Then pWorkSpace.AddArc pCenter, pRadius, pAngles(i), pAngles(i + 1)
    Next i
   
    If Not IsEqual(pAngles(pCount), pEnd) Then pWorkSpace.AddArc pCenter, pRadius, pAngles(pCount), pEnd
   
End Function

Private Function BreakCircleAtPoint(ByVal TlsCircle As AcadEntity, ByVal points)
'按点打断圆
    Dim pCount As Integer
    Dim pAngles() As Double
    Dim pRadius As Double, pCenter
   
    pRadius = TlsCircle.radius
    pCenter = TlsCircle.Center
    pCount = UBound(points)
   
    ReDim pAngles(pCount) As Double
    For i = 0 To pCount
        pAngles(i) = ThisDrawing.Utility.AngleFromXAxis(pCenter, points(i))
    Next i
   
    SortValue pAngles, pCount
   
    For i = 0 To pCount - 1
        If Not IsEqual(pAngles(i), pAngles(i + 1)) Then pWorkSpace.AddArc pCenter, pRadius, pAngles(i), pAngles(i + 1)
    Next i
   
    If Not IsEqual(pAngles(pCount), pAngles(0)) Then pWorkSpace.AddArc pCenter, pRadius, pAngles(pCount), pAngles(0)
   
End Function

Private Function BreakEllipseAtPoint(ByVal TlsEllipse As AcadEntity, ByVal points)
'按点打断椭圆
    Dim pCount As Integer
    Dim pAngles() As Double
    Dim pRadius As Double, pCenter, pMajorAxis
    Dim pEllipse As AcadEllipse
    Dim pAngle As Double
    Dim pLine As AcadLine
    Dim pnt(2) As Double
   
    pCount = UBound(points)
   
    '获取原椭圆信息
    pStart = TlsEllipse.StartAngle
    pEnd = TlsEllipse.EndAngle
    pRadius = TlsEllipse.RadiusRatio
    pCenter = TlsEllipse.Center
    pMajorAxis = TlsEllipse.MajorAxis
   
    '计算长轴向量角度
    Set pLine = pWorkSpace.AddLine(pnt, pMajorAxis)
    pAngle = pLine.Angle
    pLine.Delete
    ReDim pAngles(pCount) As Double
   
    '获取打断点的角度
    For i = 0 To pCount
        pAngles(i) = ThisDrawing.Utility.AngleFromXAxis(pCenter, points(i)) - pAngle
        If pAngles(i) < 0 Then pAngles(i) = pAngles(i) + Atn(1) * 8
        If pStart > pEnd And pAngles(i) < pEnd Then pAngles(i) = pAngles(i) + Atn(1) * 8
    Next i
    If pStart > pEnd Then pEnd = pEnd + Atn(1) * 8
   
    '将角度排序
    SortValue pAngles, pCount
   
    '打断椭圆
    For i = 0 To pCount - 1
        If Not IsEqual(pAngles(i), pAngles(i + 1)) Then
            Set pEllipse = pWorkSpace.AddEllipse(pCenter, pMajorAxis, pRadius)
            pEllipse.StartAngle = pAngles(i)
            pEllipse.EndAngle = pAngles(i + 1)
        End If
    Next i
   
    If IsEqual(pEnd - pStart, Atn(1) * 8) Then
        If Abs(pAngles(pCount) - pAngles(0)) > 10 ^ -8 Then
            Set pEllipse = pWorkSpace.AddEllipse(pCenter, pMajorAxis, pRadius)
            pEllipse.StartAngle = pAngles(pCount)
            pEllipse.EndAngle = pAngles(0)
        End If
    Else
        If Not IsEqual(pStart, pAngles(0)) Then
            Set pEllipse = pWorkSpace.AddEllipse(pCenter, pMajorAxis, pRadius)
            pEllipse.StartAngle = pStart
            pEllipse.EndAngle = pAngles(0)
        End If
        If Not IsEqual(pEnd, pAngles(pCount)) Then
            Set pEllipse = pWorkSpace.AddEllipse(pCenter, pMajorAxis, pRadius)
            pEllipse.StartAngle = pAngles(pCount)
            pEllipse.EndAngle = pEnd
        End If
    End If
   
End Function


Private Function BreakObjectAtPoint(ByVal TlsObject As AcadEntity, Optional Count)
'按交点打断图元
    Dim pnts As Variant
    Dim pObjs(0) As AcadEntity
   
    If IsMissing(Count) Then
        pnts = GetIntersection(TlsObject)
    Else
        pnts = GetIntersection(TlsObject, Count)
    End If
   
    If Not IsArray(pnts) Then
        TlsObject.Copy
    Else
        Select Case TlsObject.EntityType
        Case acLine
             Dim pLine As AcadLine
            Set pLine = TlsObject
            BreakLineAtPoint pLine, pnts
        Case acCircle
            Dim pCircle As AcadCircle
            Set pCircle = TlsObject
            BreakCircleAtPoint pCircle, pnts
        Case acArc
            Dim pArc As AcadArc
            Set pArc = TlsObject
            BreakArcAtPoint pArc, pnts
        Case acEllipse
            Dim pEllipse As AcadEllipse
            Set pEllipse = TlsObject
            BreakEllipseAtPoint pEllipse, pnts
        End Select
    End If
   
End Function

Public Sub BreakAllAtPoint()
'按交点打断所有图元
    Dim pCount As Integer
    Dim i As Integer
   
    If TypeOf pSouce Is AcadBlock Then Explode
   
    pCount = pSouce.Count
   
    For i = 0 To pCount - 1
        BreakObjectAtPoint pSouce(i), pCount
    Next i
    For i = 0 To pCount - 1
        If TypeOf pSouce Is AcadBlock Then
           pSouce(0).Delete
        Else
           pSouce(i).Delete
        End If
    Next i
   
End Sub

Public Sub CreateRegions()
'创建面域
    Dim pObjs() As AcadEntity
   
    If pBlock Is Nothing Then Exit Sub
    BreakAllAtPoint
    ReDim pObjs(pWorkSpace.Count - 1) As AcadEntity
    For i = 0 To pWorkSpace.Count - 1
        Set pObjs(i) = pWorkSpace(i)
    Next i
   
On Error Resume Next
    pRegions = pWorkSpace.AddRegion(pObjs)
   
End Sub

Private Function PointInRegion(ByVal TlsRegion, ByVal Point) As Boolean
'判断点是否在面域内
    Dim pCopy As AcadRegion, pRegion As AcadRegion
    Dim pObjs(0) As AcadEntity
    Set pCopy = TlsRegion.Copy
    Set pObjs(0) = pWorkSpace.AddCircle(Point, 0.0001)
    Set pRegion = pWorkSpace.AddRegion(pObjs)(0)
    pRegion.Boolean acIntersection, pCopy
    If pRegion.Area > 0 Then PointInRegion = True
    pRegion.Delete
    pObjs(0).Delete
   
End Function

Private Function InRegion(ByVal TlsRegion, ByVal SubRegion) As Boolean
'判断面域是否在面域内
    Dim pCopy As AcadRegion, pRegion As AcadRegion
    Dim pArea As Double
    If SubRegion.Area >= TlsRegion.Area Then Exit Function
    Set pCopy = TlsRegion.Copy
    Set pRegion = SubRegion.Copy
    pArea = pRegion.Area
    pRegion.Boolean acIntersection, pCopy
    If pRegion.Area = pArea Then InRegion = True
    pRegion.Delete
   
End Function

Private Function CreateLoop(ByVal Point) As Integer
'创建边界
On Error Resume Next
    Dim i As Integer, j As AcadEntity
    Dim m As Integer, n As Integer
    Dim pObjs(0) As AcadEntity
    Dim pRegion As AcadRegion
    Dim pArea As Double
    Dim pJudge As Boolean
    Dim pCount As Integer
   
    '遍历面域数组找到包含点的最小面域
    For i = 0 To UBound(pRegions)
        If PointInRegion(pRegions(i), Point) Then
            pJudge = True
            If pArea <> 0 Then
                If pArea > pRegions(i).Area Then
                    pArea = pRegions(i).Area
                    n = i
                End If
            Else
                pArea = pRegions(i).Area
                n = i
            End If
        End If
    Next i
   
    CreateLoop = 0
   
    '找到外边界
    If pJudge Then
   
        '复制外边界到目标块
        CreateLoop = 1
        Set pObjs(0) = pRegions(n)
        ThisDrawing.CopyObjects pObjs, pBlock
        Set OuterLoop = pBlock(pBlock.Count - 1)
        m = 0
        For i = 0 To UBound(pRegions)
            If i <> n Then
            
                '找到内边界
                If InRegion(pRegions(n), pRegions(i)) Then
                    CreateLoop = 2
                    If m = 0 Then
                        Set pRegion = pRegions(i).Copy
                    Else
                        pRegion.Boolean acUnion, pRegions(i).Copy
                    End If
                    m = m + 1
                End If
            End If
        Next i
        
        '复制内边界到目标块
        If CreateLoop = 2 Then
            Set pObjs(0) = pRegion
            ThisDrawing.CopyObjects pObjs, pBlock
            Set InnerLoop = pBlock(pBlock.Count - 1)
            pRegion.Delete
        End If
    End If
   
End Function

Public Function CreateHatch(ByVal Point, ByVal PatternName As String, Optional PatternScale As Double = 1, Optional PatternAngle As Double = 0) As AcadHatch
'创建填充
On Error Resume Next
    Dim i As Integer
    Dim phatch As AcadHatch
    Dim pJudge As Integer
    Dim pObjs(0) As AcadEntity
    Dim pInObjs As Variant
   
    If pBlock Is Nothing Then Exit Function
   
    pJudge = CreateLoop(Point)
   
    '有外边界时填充
    If pJudge > 0 Then
        Set phatch = pBlock.AddHatch(0, PatternName, False)
        Set pObjs(0) = OuterLoop
        phatch.AppendOuterLoop pObjs
        
        '有内边界时加入内边界
        If pJudge = 2 Then
            pInObjs = InnerLoop.Explode
            If pInObjs(0).ObjectName = "AcDbRegion" Then
                For i = 0 To UBound(pInObjs)
                    Set pObjs(0) = pInObjs(i)
                    phatch.AppendInnerLoop pObjs
                Next i
            Else
                    Set pObjs(0) = InnerLoop
                    phatch.AppendInnerLoop pObjs
            End If
        End If
        
        '生成填充
        phatch.PatternScale = PatternScale
        phatch.PatternAngle = PatternAngle / 45 * Atn(1)
        phatch.Evaluate
    End If
   
    '删除临时实体
    OuterLoop.Delete
    InnerLoop.Delete
    For i = 0 To UBound(pInObjs)
        pInObjs(i).Delete
    Next i
    Set CreateHatch = phatch
   
End Function
[/Code]

雪山飞狐(lzh)

调用方法
dim a as new tlsbounary
a.owner=pblock
'对pOwner属性赋值，将欲填充的块赋过来
a.CreateRegions
'调用CreateRegions方法创建面域，以生成边界
p3(1) = p3(1) + 0.5
'点的位置是pblock的填充面积中的任意点'
a.CreateHatch(p3, "ansi31", 0.1, 90).Layer = "02"
'调用CreateHatch方法按点生成填充

随缘OK

谢谢斑竹！