社区 › AutoCAD.net/VB.net/C# 编程技术 › 怎样分解属性块

pmq 发表于 2024-6-4 10:59:09

怎样分解属性块

怎样分解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 发表于 2024-6-4 18:56:34

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

OooCcc 发表于 2024-6-6 17:50:24

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

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

你有种再说一遍 发表于 2024-6-6 18:15:12

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

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

你有种再说一遍 发表于 2024-6-4 17:20:00

事务为什么套在for里面

start4444 发表于 2024-6-4 17:30:51

et好像有炸属性块

tiancao100 发表于 2024-6-4 18:57:51

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

有时候也有好处，

你有种再说一遍 发表于 2024-6-4 19:28:46

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

请上声明式事务

pmq 发表于 2024-6-4 19:37:44

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


谢谢大老的回复。:handshake

429014673 发表于 2024-6-4 21:03:28

命令burst?

煮茗 发表于 2024-6-6 10:06:02

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

tiancao100 发表于 2024-6-6 11:08:48

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

查看完整版本: 怎样分解属性块