- 积分
- 24553
- 明经币
- 个
- 注册时间
- 2004-3-17
- 在线时间
- 小时
- 威望
-
- 金钱
- 个
- 贡献
-
- 激情
-
|
楼主 |
发表于 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
|
|