[原创]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.
'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 pArea0 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 in 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
感谢分享，学习
哦哦，谢谢您
其中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_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
这是例子的填充效果图
谢谢>学习 版主，为什么会有出错提示：未找到主键？ 还有执行
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处有类型不匹配提示！ 这里要改一下 Public Property Let WorkSpace(ByVal Value As AcadBlock)
改为
Public Property Let WorkSpace(ByVal Value)
未找到主键的问题我没有碰到过，我在2002和2005下都调试通过了的
页:
[1]
2