Creating a table of block attributes in AutoCAD using .NET
Imports System
Imports System.Collections.Specialized
Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.ApplicationServices
Namespace TableCreation
Public Class Commands
' Set up some formatting constants
' for the table
Const colWidth As Double = 1500
Const rowHeight As Double = 300
Const textHeight As Double = 100
Const cellAlign As CellAlignment = CellAlignment.MiddleCenter
' Helper function to set text height
' and alignment of specific cells,
' as well as inserting the text
Public Shared Sub SetCellText(ByVal tb As Autodesk.AutoCAD.DatabaseServices.Table, ByVal row As Long, ByVal col As Long, ByVal value As String)
tb.Cells(row, col).Alignment = cellAlign
tb.Cells(row, col).TextHeight = textHeight
tb.Cells(row, col).TextString = value
'tb.SetAlignment(row, col, cellAlign)
'tb.SetTextHeight(row, col, textHeight)
'tb.SetTextString(row, col, value)
End Sub
<CommandMethod("BAT")> _
Public Shared Sub BlockAttributeTable()
Dim doc As Document = Application.DocumentManager.MdiActiveDocument
Dim db As Database = doc.Database
Dim ed As Editor = doc.Editor
' Ask for the name of the block to find
Dim opt As New PromptStringOptions(vbLf & "Enter name of block to list: ")
Dim pr As PromptResult = ed.GetString(opt)
If pr.Status = PromptStatus.OK Then
Dim blockToFind As String = pr.StringResult.ToUpper()
Dim embed As Boolean = False
' Ask whether to embed or link the data
Dim pko As New PromptKeywordOptions(vbLf & "Embed or link the attribute values: ")
pko.AllowNone = True
pko.Keywords.Add("Embed")
pko.Keywords.Add("Link")
pko.Keywords.[Default] = "Embed"
Dim pkr As PromptResult = ed.GetKeywords(pko)
If pkr.Status = PromptStatus.None OrElse pkr.Status = PromptStatus.OK Then
If pkr.Status = PromptStatus.None OrElse pkr.StringResult = "Embed" Then
embed = True
Else
embed = False
End If
End If
Dim tr As Transaction = doc.TransactionManager.StartTransaction()
Using tr
' Let's check the block exists
Dim bt As BlockTable = CType(tr.GetObject(doc.Database.BlockTableId, OpenMode.ForRead), BlockTable)
If Not bt.Has(blockToFind) Then
ed.WriteMessage(vbLf & "Block " + blockToFind + " does not exist.")
Else
' And go through looking for
' attribute definitions
Dim colNames As New StringCollection()
Dim bd As BlockTableRecord = CType(tr.GetObject(bt(blockToFind), OpenMode.ForRead), BlockTableRecord)
For Each adId As ObjectId In bd
Dim adObj As DBObject = tr.GetObject(adId, OpenMode.ForRead)
' For each attribute definition we find...
Dim ad As AttributeDefinition = TryCast(adObj, AttributeDefinition)
If ad IsNot Nothing Then
' ... we add its name to the list
colNames.Add(ad.Tag)
End If
Next
If colNames.Count = 0 Then
ed.WriteMessage(vbLf & "The block " + blockToFind + " contains no attribute definitions.")
Else
' Ask the user for the insertion point
' and then create the table
Dim ppr As PromptPointResult = ed.GetPoint(vbLf & "Enter table insertion point: ")
If ppr.Status = PromptStatus.OK Then
Dim tb As New Table()
tb.TableStyle = db.Tablestyle
'tb.NumRows = 1
'tb.NumColumns = colNames.Count
tb.SetSize(1, colNames.Count)
tb.SetRowHeight(rowHeight)
tb.SetColumnWidth(colWidth)
tb.Position = ppr.Value
' Let's add our column headings
Dim i As Integer = 0
While i < colNames.Count
SetCellText(tb, 0, i, colNames(i))
i += 1
End While
' Now let's search for instances of
' our block in the modelspace
Dim ms As BlockTableRecord = CType(tr.GetObject(bt(BlockTableRecord.ModelSpace), OpenMode.ForRead), BlockTableRecord)
Dim rowNum As Integer = 1
For Each objId As ObjectId In ms
Dim obj As DBObject = tr.GetObject(objId, OpenMode.ForRead)
Dim br As BlockReference = TryCast(obj, BlockReference)
If br IsNot Nothing Then
Dim btr As BlockTableRecord = CType(tr.GetObject(br.BlockTableRecord, OpenMode.ForRead), BlockTableRecord)
Using btr
If btr.Name.ToUpper() = blockToFind Then
' We have found one of our blocks,
' so add a row for it in the table
tb.InsertRows(rowNum, rowHeight, 1)
' Assume that the attribute refs
' follow the same order as the
' attribute defs in the block
Dim attNum As Integer = 0
For Each arId As ObjectId In br.AttributeCollection
Dim arObj As DBObject = tr.GetObject(arId, OpenMode.ForRead)
Dim ar As AttributeReference = TryCast(arObj, AttributeReference)
If ar IsNot Nothing Then
' Embed or link the values
Dim strCell As String
If embed Then
strCell = ar.TextString
Else
Dim strArId As String = arId.ToString()
strArId = strArId.Trim(New Char() {"("c, ")"c})
strCell = "%<\AcObjProp Object(" + "%<\_ObjId " + strArId + ">%).TextString>%"
End If
SetCellText(tb, rowNum, attNum, strCell)
End If
attNum += 1
Next
rowNum += 1
End If
End Using
End If
Next
tb.GenerateLayout()
ms.UpgradeOpen()
ms.AppendEntity(tb)
tr.AddNewlyCreatedDBObject(tb, True)
tr.Commit()
End If
End If
End If
End Using
End If
End Sub
End Class
End Namespace
深度开源