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

雪山飞狐_lzh · 发表于 2004-5-24 11:25:00

本帖最后由作者于 2004-5-28 10:44:20 编辑

'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.

雪山飞狐_lzh · 发表于 2004-5-27 19:27:00

本帖最后由作者于 2005-4-9 15:15:15 编辑

'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) < 10 ^ -8
End FunctionPublic Property Let WorkSpace(ByVal Value)'边界所有者
On Error Resume Next Dim pnt(2) As Double
Set pBlock = Nothing
pWorkSpace.Delete
Err.Clear
If TypeOf Value Is AcadBlock Then
Set pBlock = Value
Set pWorkSpace = ThisDrawing.Blocks.Add(pnt, "*U")
Set pSouce = pWorkSpace
pWorkSpace.InsertBlock pnt, Value.Name, 1, 1, 1, 0
ElseIf TypeOf Value Is AcadSelectionSet Then
Set pSouce = Value
Set pWorkSpace = ThisDrawing.ModelSpace
End If
End PropertyPublic 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 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)) < 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 FunctionPrivate 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 FunctionPrivate 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 FunctionPrivate 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 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

'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) < 10 ^ -8
       
End FunctionPublic Property Let WorkSpace(ByVal Value)'边界所有者
On Error Resume Next       Dim pnt(2) As Double
       
       Set pBlock = Nothing
       pWorkSpace.Delete
       Err.Clear
       
       If TypeOf Value Is AcadBlock Then
       
               Set pBlock = Value
               Set pWorkSpace = ThisDrawing.Blocks.Add(pnt, "*U")
               Set pSouce = pWorkSpace
               pWorkSpace.InsertBlock pnt, Value.Name, 1, 1, 1, 0
               
       ElseIf TypeOf Value Is AcadSelectionSet Then
       
               Set pSouce = Value
               Set pWorkSpace = ThisDrawing.ModelSpace
               
       End If
       
End PropertyPublic 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 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)) < 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 FunctionPrivate 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 FunctionPrivate 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 FunctionPrivate 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 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

wykdy · 发表于 2013-12-3 00:57:55

感谢分享，学习

elepeipei · 发表于 2017-12-6 22:33:15

雪山飞狐_lzh 发表于 2017-12-5 21:29
自己建一个类然后把代码copy进去

哦哦，谢谢您

雪山飞狐_lzh · 发表于 2004-5-24 11:28:00

本帖最后由作者于 2004-6-1 10:44:26 编辑

其中Break???AtPoint、GetIntersection、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.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()
       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

雪山飞狐_lzh · 发表于 2004-5-24 11:32:00

这是例子的填充效果图

yingxunxue · 发表于 2004-5-27 09:37:00

谢谢>学习

maxsoft · 发表于 2004-9-30 09:10:00

版主，为什么会有出错提示：未找到主键？

maxsoft · 发表于 2004-9-30 12:13:00

还有执行 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 时pBoundary.WorkSpace = SS处有类型不匹配提示！

雪山飞狐_lzh · 发表于 2004-9-30 20:36:00

这里要改一下 Public Property Let WorkSpace(ByVal Value As AcadBlock)
改为 Public Property Let WorkSpace(ByVal Value)
未找到主键的问题我没有碰到过，我在2002和2005下都调试通过了的

cxjzxh · 发表于 2013-4-29 11:27:51

感谢楼主分享

账号		自动登录	找回密码
密码			注册

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

本帖子中包含更多资源