田草博客
日志搜索


 标题   内容 评论


网友交流QQ群:11740834 需注明申请加入原因

微信 公众号:ByCAD

邮箱:tiancao1001x126.com
ByCAD,微信公众号 ByCAD,微信公众号
首页 | 普通 | 电脑 | AutoCAD | VB/VB.NET | FLash | 结构 | 建筑 | 电影 | BIM | 规范 | 软件
-电信用户-|-网通用户-
-博客论坛-|-软件下载-
-网站导航-|-规范下载-
-BelovedFLash欣赏-

用户登陆
用户:
密码:
 

站点日历
73 2019 - 7 48
 123456
78910111213
14151617181920
21222324252627
28293031


站点统计

最新评论



深度开源 板筋矫正
未知 Creating a table of block attributes in AutoCAD   [ 日期:2019-06-29 ]   [ 来自:本站原创 ]  HTML


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




[本日志由 tiancao1001 于 2019-06-29 06:32 PM 编辑]


暂时没有评论
发表评论 - 不要忘了输入验证码哦!
作者: 用户:  密码:   注册? 验证:  防止恶意留言请输入问题答案:2*9=?  
评论:

禁止表情
禁止UBB
禁止图片
识别链接
识别关键字

字体样式 文字大小 文字颜色
插入粗体文本 插入斜体文本 插入下划线
左对齐 居中对齐 右对齐
插入超级链接 插入邮件地址 插入图像
插入 Flash 插入代码 插入引用
插入列表 插入音频文件 插入视频文件
插入缩进符合
点击下载按钮 下标 上标
水平线 简介分割标记
表  情
 
Tiancao Blog All Rights Reserved 田草博客 版权所有
Copyright ©