怎样分解属性块

pmq

怎样分解CASS高程点，此程序分解为最后一行那样 ，正常应是第一行那样。

        Dim DocLock As DocumentLock = Core.Application.DocumentManager.MdiActiveDocument.LockDocument()
        NativeMethods.SetFocus(Core.Application.DocumentManager.MdiActiveDocument.Window.Handle) 'CAD获得焦点
        Dim ed As Editor = Core.Application.DocumentManager.MdiActiveDocument.Editor '对话框
        Dim db As Database = HostApplicationServices.WorkingDatabase '数据库对象  
        Dim psr As PromptSelectionResult '请求在图形区域选择对象
        Dim SetA As SelectionSet '= Nothing
        psr = ed.GetSelection() '屏幕选取
        If psr.Status = PromptStatus.OK Then '如果提示状态OK，表示对象已选
            SetA = psr.Value
            Dim ids As ObjectId() = SetA.GetObjectIds
            For Each obj In SetA
                Using cTrans As Transaction = db.TransactionManager.StartTransaction() '开启事务处理
                    Dim entity As Entity = CType(cTrans.GetObject(obj.ObjectId, OpenMode.ForWrite, True), Entity)
                    Using dbObjCol As New DBObjectCollection
                        entity.Explode(dbObjCol)

                        For Each dbObj As DBObject In dbObjCol
                            Dim acEnt As Entity = dbObj
                            acEnt.ColorIndex = 6 '颜色索引
                            AppendEntity(acEnt)
                            ？？？
                            acEnt = cTrans.GetObject(dbObj.ObjectId, OpenMode.ForWrite)
                            ed.WriteMessage(vbLf & "Exploded Object: " & acEnt.GetRXClass().DxfName)
                        Next
                    End Using
                    cTrans.Commit()
                End Using
            Next
        End If

        '''https://www.cadn.net.cn/portal.php?mod=view&aid=11626'原文

tiancao100

2. <CommandMethod("TcExplodeAtt")>
   
3.     Public Sub TcExplodeAtt()
   
4.         On Error Resume Next
   
5.         Dim acDoc As Document = Application.DocumentManager.MdiActiveDocument
   
6.         Dim acCurDb As Database = acDoc.Database
   
7.         Dim acEditor As Editor = acDoc.Editor
   
8.         Dim acTypValAr(0) As TypedValue
   
9.         acTypValAr.SetValue(New TypedValue(DxfCode.Start, "INSERT,ATTDEF"), 0) '过滤参照块和属性
   
10.         Dim acSelFtr As SelectionFilter = New SelectionFilter(acTypValAr)
    
11.         Dim acSSPrompt As PromptSelectionResult = acEditor.GetSelection(acSelFtr)
    
12.         If acSSPrompt.Status <> PromptStatus.OK Then
    
13.             Exit Sub
    
14.         End If
    
15.         Dim acSSet As SelectionSet = acSSPrompt.Value
    
16.         Using acTrans As Transaction = acCurDb.TransactionManager.StartTransaction()
    
17.             For Each OBJ As Object In acSSet
    
18.                 Dim E As Entity = acTrans.GetObject(OBJ.ObjectId, OpenMode.ForWrite)
    
19.                 If E.GetRXClass.DxfName = "INSERT" Then
    
20.                     Dim BRef As BlockReference = CType(E, BlockReference)
    
21.                     Dim AttCollection As AttributeCollection
    
22.                     AttCollection = BRef.AttributeCollection
    
23.                     If AttCollection.Count < 1 Then
    
24.                         BRef.ExplodeToOwnerSpace()
    
25.                         BRef.Erase()
    
26.                     Else
    
27.                         'Dim AttRef As AttributeReference
    
28.                         'For I As Int16 = 0 To AttCollection.Count - 1
    
29.                         '    AttRef = acTrans.GetObject(AttCollection(I), OpenMode.ForRead, False)
    
30.                         '    If AttRef.IsMTextAttribute = False Then
    
31.                         '        Dim DBT As DBText = New DBText()
    
32.                         '        DBT.Rotation = AttRef.Rotation
    
33.                         '        DBT.TextString = AttRef.TextString
    
34.                         '        DBT.WidthFactor = AttRef.WidthFactor
    
35.                         '        DBT.Height = AttRef.Height
    
36.                         '        DBT.TextStyleId = AttRef.TextStyleId
    
37.                         '        DBT.LayerId = AttRef.LayerId
    
38.                         '        DBT.LinetypeId = AttRef.LinetypeId
    
39.                         '        DBT.Position = AttRef.Position
    
40.                         '        AddEnt(DBT)
    
41.                         '    Else
    
42.                         '        Dim DBT As MText = AttRef.MTextAttribute
    
43.                         '        AddEnt(DBT)
    
44.                         '    End If
    
45.                         'Next
    
46.                         '以下方法分解后AttDef可能缺失
    
47.                         Dim DBC As DBObjectCollection = New DBObjectCollection
    
48.                         'BRef.ExplodeToOwnerSpace()
    
49.                         BRef.Explode(DBC)
    
50.                         Dim N As Long = 0
    
51.                         For Each dbObj As DBObject In DBC
    
52.                             Dim acEnt As Entity = dbObj
    
53.                             If acEnt.GetRXClass().DxfName.ToUpper = "ATTDEF" Then
    
54.                                 Dim DBT As DBText = New DBText()
    
55.                                 Dim AttRef As AttributeReference
    
56.                                 AttRef = acTrans.GetObject(AttCollection(N), OpenMode.ForWrite, False)
    
57.                                 DBT.Rotation = AttRef.Rotation
    
58.                                 DBT.TextString = AttRef.TextString
    
59.                                 DBT.WidthFactor = AttRef.WidthFactor
    
60.                                 DBT.Height = AttRef.Height
    
61.                                 DBT.TextStyleId = AttRef.TextStyleId
    
62.                                 DBT.LayerId = AttRef.LayerId
    
63.                                 DBT.LinetypeId = AttRef.LinetypeId
    
64.                                 DBT.Position = AttRef.Position
    
65.                                 AddEnt(DBT)
    
66.                                 N = N + 1
    
67.                             Else
    
68.                                 AddEnt(acEnt)
    
69.                             End If
    
70.                             'MsgBox("Exploded Object: " & acEnt.GetRXClass().DxfName)
    
71.                         Next
    
72.                         BRef.Erase()
    
73.                     End If
    
74.                 Else
    
75.                     Dim DBT As DBText = New DBText()
    
76.                     Dim AttRef As AttributeDefinition = CType(E, AttributeDefinition)
    
77.                     DBT.Rotation = AttRef.Rotation
    
78.                     DBT.TextString = AttRef.TextString
    
79.                     DBT.WidthFactor = AttRef.WidthFactor
    
80.                     DBT.Height = AttRef.Height
    
81.                     DBT.TextStyleId = AttRef.TextStyleId
    
82.                     DBT.LayerId = AttRef.LayerId
    
83.                     DBT.LinetypeId = AttRef.LinetypeId
    
84.                     DBT.Position = AttRef.Position
    
85.                     AddEnt(DBT)
    
86.                     E.Erase()
    
87.                 End If
    
88.             Next
    
89.             acTrans.Commit()
    
90.         End Using
    
91.         If Err.Number > 0 Then
    
92.             MsgBox(Err.Description)
    
93.         End If
    
94.     End Sub

<CommandMethod("TcExplodeAtt")><br />     Public Sub TcExplodeAtt()<br />         On Error Resume Next<br />         Dim acDoc As Document = Application.DocumentManager.MdiActiveDocument<br />         Dim acCurDb As Database = acDoc.Database<br />         Dim acEditor As Editor = acDoc.Editor<br />         Dim acTypValAr(0) As TypedValue<br />         acTypValAr.SetValue(New TypedValue(DxfCode.Start, "INSERT,ATTDEF"), 0) '过滤参照块和属性<br />         Dim acSelFtr As SelectionFilter = New SelectionFilter(acTypValAr)<br />         Dim acSSPrompt As PromptSelectionResult = acEditor.GetSelection(acSelFtr)<br />         If acSSPrompt.Status <> PromptStatus.OK Then<br />             Exit Sub<br />         End If<br />         Dim acSSet As SelectionSet = acSSPrompt.Value<br />         Using acTrans As Transaction = acCurDb.TransactionManager.StartTransaction()<br />             For Each OBJ As Object In acSSet<br />                 Dim E As Entity = acTrans.GetObject(OBJ.ObjectId, OpenMode.ForWrite)<br />                 If E.GetRXClass.DxfName = "INSERT" Then<br />                     Dim BRef As BlockReference = CType(E, BlockReference)<br />                     Dim AttCollection As AttributeCollection<br />                     AttCollection = BRef.AttributeCollection<br />                     If AttCollection.Count < 1 Then<br />                         BRef.ExplodeToOwnerSpace()<br />                         BRef.Erase()<br />                     Else<br />                         'Dim AttRef As AttributeReference<br />                         'For I As Int16 = 0 To AttCollection.Count - 1<br />                         '    AttRef = acTrans.GetObject(AttCollection(I), OpenMode.ForRead, False)<br />                         '    If AttRef.IsMTextAttribute = False Then<br />                         '        Dim DBT As DBText = New DBText()<br />                         '        DBT.Rotation = AttRef.Rotation<br />                         '        DBT.TextString = AttRef.TextString<br />                         '        DBT.WidthFactor = AttRef.WidthFactor<br />                         '        DBT.Height = AttRef.Height<br />                         '        DBT.TextStyleId = AttRef.TextStyleId<br />                         '        DBT.LayerId = AttRef.LayerId<br />                         '        DBT.LinetypeId = AttRef.LinetypeId<br />                         '        DBT.Position = AttRef.Position<br />                         '        AddEnt(DBT)<br />                         '    Else<br />                         '        Dim DBT As MText = AttRef.MTextAttribute<br />                         '        AddEnt(DBT)<br />                         '    End If<br />                         'Next<br />                         '以下方法分解后AttDef可能缺失<br />                         Dim DBC As DBObjectCollection = New DBObjectCollection<br />                         'BRef.ExplodeToOwnerSpace()<br />                         BRef.Explode(DBC)<br />                         Dim N As Long = 0<br />                         For Each dbObj As DBObject In DBC<br />                             Dim acEnt As Entity = dbObj<br />                             If acEnt.GetRXClass().DxfName.ToUpper = "ATTDEF" Then<br />                                 Dim DBT As DBText = New DBText()<br />                                 Dim AttRef As AttributeReference<br />                                 AttRef = acTrans.GetObject(AttCollection(N), OpenMode.ForWrite, False)<br />                                 DBT.Rotation = AttRef.Rotation<br />                                 DBT.TextString = AttRef.TextString<br />                                 DBT.WidthFactor = AttRef.WidthFactor<br />                                 DBT.Height = AttRef.Height<br />                                 DBT.TextStyleId = AttRef.TextStyleId<br />                                 DBT.LayerId = AttRef.LayerId<br />                                 DBT.LinetypeId = AttRef.LinetypeId<br />                                 DBT.Position = AttRef.Position<br />                                 AddEnt(DBT)<br />                                 N = N + 1<br />                             Else<br />                                 AddEnt(acEnt)<br />                             End If<br />                             'MsgBox("Exploded Object: " & acEnt.GetRXClass().DxfName)<br />                         Next<br />                         BRef.Erase()<br />                     End If<br />                 Else<br />                     Dim DBT As DBText = New DBText()<br />                     Dim AttRef As AttributeDefinition = CType(E, AttributeDefinition)<br />                     DBT.Rotation = AttRef.Rotation<br />                     DBT.TextString = AttRef.TextString<br />                     DBT.WidthFactor = AttRef.WidthFactor<br />                     DBT.Height = AttRef.Height<br />                     DBT.TextStyleId = AttRef.TextStyleId<br />                     DBT.LayerId = AttRef.LayerId<br />                     DBT.LinetypeId = AttRef.LinetypeId<br />                     DBT.Position = AttRef.Position<br />                     AddEnt(DBT)<br />                     E.Erase()<br />                 End If<br />             Next<br />             acTrans.Commit()<br />         End Using<br />         If Err.Number > 0 Then<br />             MsgBox(Err.Description)<br />         End If<br />     End Sub

OooCcc

tiancao100 发表于 2024-6-6 11:08
BURST 是Express Tools中的， 仍然只能分解允许分解的，创建时不允许分解的他也爆不了， 也不能分解属性

可以使用(vla-put-explodable blk -1)来使块允许分解，然后再用BURST来进行分解

你有种再说一遍

OooCcc 发表于 2024-6-6 17:50
可以使用(vla-put-explodable blk -1)来使块允许分解，然后再用BURST来进行分解

net不用,能够读取就自己创建就好了

你有种再说一遍

事务为什么套在for里面

start4444

et好像有炸属性块

tiancao100

你有种再说一遍 发表于 2024-6-4 17:20
事务为什么套在for里面

有时候也有好处，

你有种再说一遍

tiancao100 发表于 2024-6-4 18:57
有时候也有好处，

请上声明式事务

pmq

tiancao100 发表于 2024-6-4 18:56

谢谢大老的回复。

429014673

命令burst?

煮茗

CAD自带命令 BURST 试试。可以分解属性块保留属性值。

tiancao100

BURST 是Express Tools中的， 仍然只能分解允许分解的，创建时不允许分解的他也爆不了， 也不能分解属性