明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 8333|回复: 17

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

[复制链接]
发表于 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.
 楼主| 发表于 2004-5-27 19:27:00 | 显示全部楼层
本帖最后由 作者 于 2005-4-9 15:15:15 编辑
  1. 'TlsBoundary类,专用于在块内按点生成填充
  2. '编制:天龙工作室 ' You may use the code included in this module in any way,
  3. ' provided that both the above copyright notice and the
  4. ' release of liability (stated below) appear in all copies.
  5. Private pSouce As Object
  6. Private pBlock As AcadBlock
  7. Private pWorkSpace As AcadObject
  8. Private pRegions As Variant
  9. Private OuterLoop As AcadRegion
  10. Private InnerLoop As AcadRegionPrivate Sub Class_Terminate()
  11. On Error Resume Next
  12.       
  13.        pWorkSpace.Delete
  14.       
  15. End SubPrivate Function IsEqual(ByVal Value1 As Double, ByVal Value2 As Double) As Boolean       IsEqual = Abs(Value1 - Value2) < 10 ^ -8
  16.       
  17. End FunctionPublic Property Let WorkSpace(ByVal Value)'边界所有者
  18. On Error Resume Next       Dim pnt(2) As Double
  19.       
  20.        Set pBlock = Nothing
  21.        pWorkSpace.Delete
  22.        Err.Clear
  23.       
  24.        If TypeOf Value Is AcadBlock Then
  25.       
  26.                Set pBlock = Value
  27.                Set pWorkSpace = ThisDrawing.Blocks.Add(pnt, "*U")
  28.                Set pSouce = pWorkSpace
  29.                pWorkSpace.InsertBlock pnt, Value.Name, 1, 1, 1, 0
  30.                
  31.        ElseIf TypeOf Value Is AcadSelectionSet Then
  32.       
  33.                Set pSouce = Value
  34.                Set pWorkSpace = ThisDrawing.ModelSpace
  35.                
  36.        End If
  37.       
  38. End PropertyPublic Sub Explode()
  39. '将所有图元炸开为基本图元
  40. On Error Resume Next
  41.        Dim pCanBeExploded As Boolean
  42.        Dim i As AcadEntity
  43.       
  44.        pCanBeExploded = True
  45.       
  46.        Do While pCanBeExploded
  47.       
  48.                pCanBeExploded = False
  49.                
  50.                For Each i In pWorkSpace
  51.                
  52.                        If _
  53.                                i.ObjectName <> "AcDbLine" And _
  54.                                i.ObjectName <> "AcDbCircle" And _
  55.                                i.ObjectName <> "AcDbArc" And _
  56.                                i.ObjectName <> "AcDbEllipse" _
  57.                        Then
  58.                                i.Explode
  59.                                Err.Clear
  60.                                i.Delete
  61.                                pCanBeExploded = True
  62.                        End If
  63.                        
  64.                Next i
  65.                
  66.        Loop
  67.       
  68. End SubPrivate Sub SortValue(ByRef Values As Variant, ByVal Count As Integer)
  69. '值排序
  70.        Dim pTemp As Double
  71.       
  72.        For i = Count To 1 Step -1
  73.       
  74.                For j = 0 To i - 1
  75.                
  76.                        If Values(j) > Values(j + 1) Then
  77.                                pTemp = Values(j + 1)
  78.                                Values(j + 1) = Values(j)
  79.                                Values(j) = pTemp
  80.                        End If
  81.                        
  82.                Next j
  83.                
  84.        Next i
  85. End SubPrivate Sub SortPoint(ByRef Values As Variant, ByRef Points As Variant, ByVal Count As Integer)
  86. '按值将点数组排序
  87.        Dim pTemp As Double, pnt As Variant
  88.       
  89.        For i = Count To 1 Step -1
  90.       
  91.                For j = 0 To i - 1
  92.                
  93.                        If Values(j) > Values(j + 1) Then
  94.                                pTemp = Values(j + 1)
  95.                                Values(j + 1) = Values(j)
  96.                                Values(j) = pTemp
  97.                                pnt = Points(j + 1)
  98.                                Points(j + 1) = Points(j)
  99.                                Points(j) = pnt
  100.                        End If
  101.                        
  102.                Next j
  103.                
  104.        Next i
  105.       
  106. End SubPrivate Function GetIntersection(ByVal TlsObject As AcadEntity, Optional ByVal Count)
  107. '获取图元的全部交点
  108.        Dim pnts(), dot
  109.        Dim pnt(2) As Double
  110.        Dim n As Integer
  111.        Dim i, j
  112.        Dim pNum As Integer
  113.       
  114.        If IsMissing(Count) Then Count = pSouce.Count
  115.       
  116.        For i = 0 To Count - 1
  117.       
  118.                If Not (TlsObject Is pSouce(i)) Then
  119.                
  120.                        dot = TlsObject.IntersectWith(pSouce(i), acExtendNone)
  121.                        n = (UBound(dot) + 1) / 3
  122.                        For j = 0 To n - 1
  123.                                pnt(0) = dot(j * 3)
  124.                                pnt(1) = dot(j * 3 + 1)
  125.                                ReDim Preserve pnts(pNum)
  126.                                pnts(pNum) = pnt
  127.                                pNum = pNum + 1
  128.                        Next j
  129.                        
  130.                End If
  131.                
  132.        Next i
  133.       
  134.        If pNum = 0 Then
  135.                GetIntersection = False
  136.        ElseIf pNum = 1 Then
  137.                If TlsObject.ObjectName = "AcDbLine" Then
  138.                        GetIntersection = pnts
  139.                ElseIf TlsObject.ObjectName = "AcDbCircle" Then
  140.                        GetIntersection = False
  141.                ElseIf Abs(TlsObject.EndAngle - TlsObject.StartAngle - Atn(1) * 8) > 10 ^ -8 Then
  142.                        GetIntersection = False
  143.                Else
  144.                        GetIntersection = pnts
  145.                End If
  146.        Else
  147.                GetIntersection = pnts
  148.        End If
  149.       
  150. End Function
  151. Private Function BreakLineAtPoint(ByVal TlsLine As AcadEntity, ByVal Points)
  152. '按点打断直线
  153.        Dim pStart, PEnd
  154.        Dim pNum As Integer
  155.        Dim pCount As Integer
  156.        Dim pDistances() As Double
  157.       
  158.        pStart = TlsLine.StartPoint
  159.        PEnd = TlsLine.EndPoint
  160.        pCount = UBound(Points)
  161.       
  162.        If Abs(Tan(TlsLine.Angle)) < 1 Then pNum = 0 Else pNum = 1
  163.       
  164.        ReDim pDistances(pCount) As Double
  165.        For i = 0 To pCount
  166.                pDistances(i) = Abs(Points(i)(pNum) - pStart(pNum))
  167.        Next i
  168.       
  169.        SortPoint pDistances, Points, pCount
  170.       
  171.        If Not IsEqual(pDistances(0), 0) Then pWorkSpace.AddLine pStart, Points(0)
  172.       
  173.        For i = 0 To pCount - 1
  174.                If Not IsEqual(pDistances(i), pDistances(i + 1)) Then pWorkSpace.AddLine Points(i), Points(i + 1)
  175.        Next i
  176.       
  177.        If Not IsEqual(Points(pCount)(pNum), PEnd(pNum)) Then pWorkSpace.AddLine Points(pCount), PEnd
  178.       
  179. End FunctionPrivate Function BreakArcAtPoint(ByVal TlsArc As AcadEntity, ByVal Points)
  180. '按点打断圆弧
  181.        Dim pStart As Variant, PEnd As Variant
  182.        Dim pCount As Integer
  183.        Dim pAngles() As Double
  184.        Dim pRadius As Double, pCenter
  185.       
  186.        pStart = TlsArc.StartAngle
  187.        PEnd = TlsArc.EndAngle
  188.        pRadius = TlsArc.radius
  189.        pCenter = TlsArc.Center
  190.        pCount = UBound(Points)
  191.       
  192.        ReDim pAngles(pCount) As Double
  193.        For i = 0 To pCount
  194.                pAngles(i) = ThisDrawing.Utility.AngleFromXAxis(pCenter, Points(i))
  195.                If pStart > PEnd And pAngles(i) < PEnd Then pAngles(i) = pAngles(i) + Atn(1) * 8
  196.        Next i
  197.       
  198.        SortValue pAngles, pCount
  199.       
  200.        If Not IsEqual(pAngles(0), 0) Then pWorkSpace.AddArc pCenter, pRadius, pStart, pAngles(0)
  201.       
  202.        For i = 0 To pCount - 1
  203.                If Not IsEqual(pAngles(i), pAngles(i + 1)) Then pWorkSpace.AddArc pCenter, pRadius, pAngles(i), pAngles(i + 1)
  204.        Next i
  205.       
  206.        If Not IsEqual(pAngles(pCount), PEnd) Then pWorkSpace.AddArc pCenter, pRadius, pAngles(pCount), PEnd
  207.       
  208. End FunctionPrivate Function BreakCircleAtPoint(ByVal TlsCircle As AcadEntity, ByVal Points)
  209. '按点打断圆
  210.        Dim pCount As Integer
  211.        Dim pAngles() As Double
  212.        Dim pRadius As Double, pCenter
  213.       
  214.        pRadius = TlsCircle.radius
  215.        pCenter = TlsCircle.Center
  216.        pCount = UBound(Points)
  217.       
  218.        ReDim pAngles(pCount) As Double
  219.        For i = 0 To pCount
  220.                pAngles(i) = ThisDrawing.Utility.AngleFromXAxis(pCenter, Points(i))
  221.        Next i
  222.       
  223.        SortValue pAngles, pCount
  224.       
  225.        For i = 0 To pCount - 1
  226.                If Not IsEqual(pAngles(i), pAngles(i + 1)) Then pWorkSpace.AddArc pCenter, pRadius, pAngles(i), pAngles(i + 1)
  227.        Next i
  228.       
  229.        If Not IsEqual(pAngles(pCount), pAngles(0)) Then pWorkSpace.AddArc pCenter, pRadius, pAngles(pCount), pAngles(0)
  230.       
  231. End FunctionPrivate Function BreakEllipseAtPoint(ByVal TlsEllipse As AcadEntity, ByVal Points)
  232. '按点打断椭圆
  233.        Dim pCount As Integer
  234.        Dim pAngles() As Double
  235.        Dim pRadius As Double, pCenter, pMajorAxis
  236.        Dim pEllipse As AcadEllipse
  237.        Dim pAngle As Double
  238.        Dim pLine As AcadLine
  239.        Dim pnt(2) As Double
  240.       
  241.        pCount = UBound(Points)
  242.       
  243.        '获取原椭圆信息
  244.        pStart = TlsEllipse.StartAngle
  245.        PEnd = TlsEllipse.EndAngle
  246.        pRadius = TlsEllipse.RadiusRatio
  247.        pCenter = TlsEllipse.Center
  248.        pMajorAxis = TlsEllipse.MajorAxis
  249.       
  250.        '计算长轴向量角度
  251.        Set pLine = pWorkSpace.AddLine(pnt, pMajorAxis)
  252.        pAngle = pLine.Angle
  253.        pLine.Delete
  254.        ReDim pAngles(pCount) As Double
  255.       
  256.        '获取打断点的角度
  257.        For i = 0 To pCount
  258.                pAngles(i) = ThisDrawing.Utility.AngleFromXAxis(pCenter, Points(i)) - pAngle
  259.                If pAngles(i) < 0 Then pAngles(i) = pAngles(i) + Atn(1) * 8
  260.                If pStart > PEnd And pAngles(i) < PEnd Then pAngles(i) = pAngles(i) + Atn(1) * 8
  261.        Next i
  262.        If pStart > PEnd Then PEnd = PEnd + Atn(1) * 8
  263.       
  264.        '将角度排序
  265.        SortValue pAngles, pCount
  266.       
  267.        '打断椭圆
  268.        For i = 0 To pCount - 1
  269.                If Not IsEqual(pAngles(i), pAngles(i + 1)) Then
  270.                        Set pEllipse = pWorkSpace.AddEllipse(pCenter, pMajorAxis, pRadius)
  271.                        pEllipse.StartAngle = pAngles(i)
  272.                        pEllipse.EndAngle = pAngles(i + 1)
  273.                End If
  274.        Next i
  275.       
  276.        If IsEqual(PEnd - pStart, Atn(1) * 8) Then
  277.                If Abs(pAngles(pCount) - pAngles(0)) > 10 ^ -8 Then
  278.                        Set pEllipse = pWorkSpace.AddEllipse(pCenter, pMajorAxis, pRadius)
  279.                        pEllipse.StartAngle = pAngles(pCount)
  280.                        pEllipse.EndAngle = pAngles(0)
  281.                End If
  282.        Else
  283.                If Not IsEqual(pStart, pAngles(0)) Then
  284.                        Set pEllipse = pWorkSpace.AddEllipse(pCenter, pMajorAxis, pRadius)
  285.                        pEllipse.StartAngle = pStart
  286.                        pEllipse.EndAngle = pAngles(0)
  287.                End If
  288.                If Not IsEqual(PEnd, pAngles(pCount)) Then
  289.                        Set pEllipse = pWorkSpace.AddEllipse(pCenter, pMajorAxis, pRadius)
  290.                        pEllipse.StartAngle = pAngles(pCount)
  291.                        pEllipse.EndAngle = PEnd
  292.                End If
  293.        End If
  294.       
  295. End Function
  296. Private Function BreakObjectAtPoint(ByVal TlsObject As AcadEntity, Optional Count)
  297. '按交点打断图元
  298.        Dim pnts As Variant
  299.        Dim pobjs(0) As AcadEntity
  300.       
  301.        If IsMissing(Count) Then
  302.                pnts = GetIntersection(TlsObject)
  303.        Else
  304.                pnts = GetIntersection(TlsObject, Count)
  305.        End If
  306.       
  307.        If Not IsArray(pnts) Then
  308.                TlsObject.Copy
  309.        Else
  310.                Select Case TlsObject.EntityType
  311.                Case acLine
  312.                          Dim pLine As AcadLine
  313.                        Set pLine = TlsObject
  314.                        BreakLineAtPoint pLine, pnts
  315.                Case acCircle
  316.                        Dim pCircle As AcadCircle
  317.                        Set pCircle = TlsObject
  318.                        BreakCircleAtPoint pCircle, pnts
  319.                Case acArc
  320.                        Dim pArc As AcadArc
  321.                        Set pArc = TlsObject
  322.                        BreakArcAtPoint pArc, pnts
  323.                Case acEllipse
  324.                        Dim pEllipse As AcadEllipse
  325.                        Set pEllipse = TlsObject
  326.                        BreakEllipseAtPoint pEllipse, pnts
  327.                End Select
  328.        End If
  329.       
  330. End FunctionPublic Sub BreakAllAtPoint()
  331. '按交点打断所有图元
  332.        Dim pCount As Integer
  333.        Dim i As Integer
  334.       
  335.        If TypeOf pSouce Is AcadBlock Then Explode
  336.       
  337.        pCount = pSouce.Count
  338.       
  339.        For i = 0 To pCount - 1
  340.                BreakObjectAtPoint pSouce(i), pCount
  341.        Next i
  342.        For i = 0 To pCount - 1
  343.                If TypeOf pSouce Is AcadBlock Then
  344.                      pSouce(0).Delete
  345.                Else
  346.                      pSouce(i).Delete
  347.                End If
  348.        Next i
  349.       
  350. End SubPublic Sub CreateRegions()
  351. '创建面域
  352.        Dim pobjs() As AcadEntity
  353.       
  354.        If pBlock Is Nothing Then Exit Sub
  355.        BreakAllAtPoint
  356.        ReDim pobjs(pWorkSpace.Count - 1) As AcadEntity
  357.        For i = 0 To pWorkSpace.Count - 1
  358.                Set pobjs(i) = pWorkSpace(i)
  359.        Next i
  360.       
  361. On Error Resume Next
  362.        pRegions = pWorkSpace.AddRegion(pobjs)
  363.       
  364. End SubPrivate Function PointInRegion(ByVal TlsRegion, ByVal Point) As Boolean
  365. '判断点是否在面域内
  366.        Dim pCopy As AcadRegion, pRegion As AcadRegion
  367.        Dim pobjs(0) As AcadEntity
  368.        Set pCopy = TlsRegion.Copy
  369.        Set pobjs(0) = pWorkSpace.AddCircle(Point, 0.0001)
  370.        Set pRegion = pWorkSpace.AddRegion(pobjs)(0)
  371.        pRegion.Boolean acIntersection, pCopy
  372.        If pRegion.Area > 0 Then PointInRegion = True
  373.        pRegion.Delete
  374.        pobjs(0).Delete
  375.       
  376. End FunctionPrivate Function InRegion(ByVal TlsRegion, ByVal SubRegion) As Boolean
  377. '判断面域是否在面域内
  378.        Dim pCopy As AcadRegion, pRegion As AcadRegion
  379.        Dim pArea As Double
  380.        If SubRegion.Area >= TlsRegion.Area Then Exit Function
  381.        Set pCopy = TlsRegion.Copy
  382.        Set pRegion = SubRegion.Copy
  383.        pArea = pRegion.Area
  384.        pRegion.Boolean acIntersection, pCopy
  385.        If pRegion.Area = pArea Then InRegion = True
  386.        pRegion.Delete
  387.       
  388. End FunctionPrivate Function CreateLoop(ByVal Point) As Integer
  389. '创建边界
  390. On Error Resume Next
  391.        Dim i As Integer, j As AcadEntity
  392.        Dim m As Integer, n As Integer
  393.        Dim pobjs(0) As AcadEntity
  394.        Dim pRegion As AcadRegion
  395.        Dim pArea As Double
  396.        Dim pJudge As Boolean
  397.        Dim pCount As Integer
  398.       
  399.        '遍历面域数组找到包含点的最小面域
  400.        For i = 0 To UBound(pRegions)
  401.                If PointInRegion(pRegions(i), Point) Then
  402.                        pJudge = True
  403.                        If pArea <> 0 Then
  404.                                If pArea > pRegions(i).Area Then
  405.                                        pArea = pRegions(i).Area
  406.                                        n = i
  407.                                End If
  408.                        Else
  409.                                pArea = pRegions(i).Area
  410.                                n = i
  411.                        End If
  412.                End If
  413.        Next i
  414.       
  415.        CreateLoop = 0
  416.       
  417.        '找到外边界
  418.        If pJudge Then
  419.       
  420.                '复制外边界到目标块
  421.                CreateLoop = 1
  422.                Set pobjs(0) = pRegions(n)
  423.                ThisDrawing.CopyObjects pobjs, pBlock
  424.                Set OuterLoop = pBlock(pBlock.Count - 1)
  425.                m = 0
  426.                For i = 0 To UBound(pRegions)
  427.                        If i <> n Then
  428.                        
  429.                                '找到内边界
  430.                                If InRegion(pRegions(n), pRegions(i)) Then
  431.                                        CreateLoop = 2
  432.                                        If m = 0 Then
  433.                                                Set pRegion = pRegions(i).Copy
  434.                                        Else
  435.                                                pRegion.Boolean acUnion, pRegions(i).Copy
  436.                                        End If
  437.                                        m = m + 1
  438.                                End If
  439.                        End If
  440.                Next i
  441.                
  442.                '复制内边界到目标块
  443.                If CreateLoop = 2 Then
  444.                        Set pobjs(0) = pRegion
  445.                        ThisDrawing.CopyObjects pobjs, pBlock
  446.                        Set InnerLoop = pBlock(pBlock.Count - 1)
  447.                        pRegion.Delete
  448.                End If
  449.        End If
  450.       
  451. End FunctionPublic Function CreateHatch(ByVal Point, ByVal PatternName As String, Optional PatternScale As Double = 1, Optional PatternAngle As Double = 0) As AcadHatch
  452. '创建填充
  453. On Error Resume Next
  454.        Dim i As Integer
  455.        Dim phatch As AcadHatch
  456.        Dim pJudge As Integer
  457.        Dim pobjs(0) As AcadEntity
  458.        Dim pInObjs As Variant
  459.       
  460.        If pBlock Is Nothing Then Exit Function
  461.       
  462.        pJudge = CreateLoop(Point)
  463.       
  464.        '有外边界时填充
  465.        If pJudge > 0 Then
  466.                Set phatch = pBlock.AddHatch(0, PatternName, False)
  467.                Set pobjs(0) = OuterLoop
  468.                phatch.AppendOuterLoop pobjs
  469.                
  470.                '有内边界时加入内边界
  471.                If pJudge = 2 Then
  472.                        pInObjs = InnerLoop.Explode
  473.                        If pInObjs(0).ObjectName = "AcDbRegion" Then
  474.                                For i = 0 To UBound(pInObjs)
  475.                                        Set pobjs(0) = pInObjs(i)
  476.                                        phatch.AppendInnerLoop pobjs
  477.                                Next i
  478.                        Else
  479.                                        Set pobjs(0) = InnerLoop
  480.                                        phatch.AppendInnerLoop pobjs
  481.                        End If
  482.                End If
  483.                
  484.                '生成填充
  485.                phatch.PatternScale = PatternScale
  486.                phatch.PatternAngle = PatternAngle / 45 * Atn(1)
  487.                phatch.Evaluate
  488.        End If
  489.       
  490.        '删除临时实体
  491.        OuterLoop.Delete
  492.        InnerLoop.Delete
  493.        For i = 0 To UBound(pInObjs)
  494.                pInObjs(i).Delete
  495.        Next i
  496.        Set CreateHatch = phatch
  497.       
  498. End Function
回复 支持 0 反对 1

使用道具 举报

发表于 2013-12-3 00:57:55 来自手机 | 显示全部楼层
感谢分享,学习
回复 支持 0 反对 1

使用道具 举报

发表于 2017-12-6 22:33:15 | 显示全部楼层
雪山飞狐_lzh 发表于 2017-12-5 21:29
自己建一个类 然后把代码copy进去

哦哦,谢谢您
 楼主| 发表于 2004-5-24 11:28:00 | 显示全部楼层
本帖最后由 作者 于 2004-6-1 10:44:26 编辑

其中Break???AtPoint、GetIntersection、PointInRegion和InRegion函数可单独使用下面两个例子说明如何使用
  1. Sub Sample_TlsBoundary()
  2.        Dim pBlock As AcadBlock, pObj As AcadBlockReference
  3.        Dim a As New TlsBoundary
  4.        Dim pnt(2) As Double
  5.        Dim p1(2) As Double, p2(2) As Double, p3(2) As Double, p4(2) As Double
  6.        Set pBlock = ThisDrawing.Blocks.Add(pnt, "*U")
  7.        p2(0) = 10: p3(1) = 10
  8.        p4(0) = 3: p4(1) = 3
  9.        pBlock.AddLine(p1, p2).Layer = "01"
  10.        pBlock.AddLine(p1, p3).Layer = "01"
  11.        pBlock.AddLine(p2, p3).Layer = "01"
  12.        pBlock.AddCircle(p1, 1).Layer = "01"
  13.        pBlock.AddCircle(p2, 1).Layer = "01"
  14.        pBlock.AddCircle(p3, 1).Layer = "01"
  15.        pBlock.AddCircle(p4, 1).Layer = "01"
  16.        pnt(0) = 2: pnt(1) = 2
  17.        a.WorkSpace = pBlock
  18.        a.CreateRegions
  19.        a.CreateHatch(pnt, "ansi31", 0.5).Layer = "02"
  20.        a.CreateHatch(p4, "ansi31", 0.1, 90).Layer = "02"
  21.        p1(0) = -0.5
  22.        a.CreateHatch(p1, "ansi31", 0.1, 30).Layer = "02"
  23.        p2(0) = p2(0) + 0.5
  24.        a.CreateHatch(p2, "ansi31", 0.1, 60).Layer = "02"
  25.        p3(1) = p3(1) + 0.5
  26.        a.CreateHatch(p3, "ansi31", 0.1, 90).Layer = "02"
  27.        Set pObj = ThisDrawing.ModelSpace.InsertBlock(ThisDrawing.Utility.GetPoint(, vbCrLf & "请输入插入点"), pBlock.Name, 1, 1, 1, 0)
  28. End Sub
  1. Sub Sample_TlsBoundary_Break()
  2.        Dim pBoundary As New TlsBoundary
  3.        Dim SS As AcadSelectionSet
  4.        Dim pnts As Variant
  5.        Dim i As AcadEntity
  6.        Dim ft(0) As Integer, fd(0)
  7.        ft(0) = 0
  8.        fd(0) = "Line,Circle,Arc,Ellipse"
  9.        Set SS = ThisDrawing.ActiveSelectionSet
  10.        pBoundary.WorkSpace = SS
  11.        SS.SelectOnScreen ft, fd
  12.        pBoundary.BreakAllAtPoint
  13. End Sub
 楼主| 发表于 2004-5-24 11:32:00 | 显示全部楼层
这是例子的填充效果图


       

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
发表于 2004-5-27 09:37:00 | 显示全部楼层
谢谢&gt;学习
发表于 2004-9-30 09:10:00 | 显示全部楼层
版主,为什么会有出错提示:未找到主键?
发表于 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处有类型不匹配提示!
 楼主| 发表于 2004-9-30 20:36:00 | 显示全部楼层
这里要改一下 Public Property Let WorkSpace(ByVal Value As AcadBlock)
改为 Public Property Let WorkSpace(ByVal Value)
未找到主键的问题我没有碰到过,我在2002和2005下都调试通过了的
发表于 2013-4-29 11:27:51 | 显示全部楼层
感谢楼主分享
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-11-6 07:23 , Processed in 0.181414 second(s), 26 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表