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

'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 AcadRegionPrivate Sub Class_Terminate()
On Error Resume Next
       
       pWorkSpace.Delete
       
End SubPrivate Function IsEqual(ByVal Value1 As Double, ByVal Value2 As Double) As Boolean       IsEqual = Abs(Value1 - Value2)  "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 SubPrivate 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 SubPrivate 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 SubPrivate 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))  PEnd And pAngles(i)  PEnd And pAngles(i)  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 FunctionPublic 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 SubPublic 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 SubPrivate 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 FunctionPrivate 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 FunctionPrivate 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 FunctionPublic 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

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.WorkSpace = 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 pBoundary As New TlsBoundary
       Dim SS As AcadSelectionSet
       Dim pnts As Variant
       Dim i As AcadEntity
       Dim ft(0) As Integer, fd(0)
       ft(0) = 0
       fd(0) = "Line,Circle,Arc,Ellipse"
       Set SS = ThisDrawing.ActiveSelectionSet
       pBoundary.WorkSpace = SS
       SS.SelectOnScreen ft, fd
       pBoundary.BreakAllAtPoint
End Sub