[分享]运用ACADR2005的表格功能创建明细表

Sub Main()       ' efan2000编写于2004-05-15
       ' 创建表格样式
       CreateTableStyle
       ' 创建块
       CreateBlock
       ' 创建表格
       CreateTable
End SubSub CreateTableStyle()       Dim DictObj As AcadDictionary
       Set DictObj = ThisDrawing.Database.dictionaries.Item("acad_tablestyle")       Dim keyName As String
       Dim className As String
       Dim customObj As AcadTableStyle
       keyName = "明细表"
       className = "AcDbTableStyle"
       Set customObj = DictObj.AddObject(keyName, className)
       
       ' 表格样式名称
       customObj.Name = "明细表"
       customObj.Description = "明细表表格样式"
       
       ' 由上而下
       customObj.FlowDirection = acTableBottomToTop
       
       ' 边距
       customObj.HorzCellMargin = 0
       customObj.VertCellMargin = 0
       
       ' 取消标题行
       customObj.TitleSuppressed = True
       ' 列标题行，正中对齐，字高为5
       customObj.SetAlignment acHeaderRow, acMiddleCenter
       customObj.SetTextHeight acHeaderRow, 5
       ' 数据行，正中对齐，字高为3.5
       customObj.SetAlignment acDataRow, acMiddleCenter
       customObj.SetTextHeight acDataRow, 3.5
End SubSub CreateBlock()
       Dim iPt(0 To 2) As Double
       iPt(0) = 0: iPt(1) = 0: iPt(2) = 0
       Dim BlockObj As AcadBlock
       Set BlockObj = ThisDrawing.Blocks.Add(iPt, "明细表-表头")
       iPt(0) = 5: iPt(1) = 10.5: iPt(2) = 0
       Dim MTextObj As AcadMText
       Set MTextObj = BlockObj.AddMText(iPt, 10, "单件")
       MTextObj.Height = 3.5
       MTextObj.AttachmentPoint = acAttachmentPointMiddleCenter
       MTextObj.InsertionPoint = iPt
       iPt(0) = 16: iPt(1) = 10.5: iPt(2) = 0
       Set MTextObj = BlockObj.AddMText(iPt, 12, "总计")
       MTextObj.Height = 3.5
       MTextObj.AttachmentPoint = acAttachmentPointMiddleCenter
       MTextObj.InsertionPoint = iPt
       iPt(0) = 11: iPt(1) = 3.5: iPt(2) = 0
       Set MTextObj = BlockObj.AddMText(iPt, 22, "重量")
       MTextObj.Height = 3.5
       MTextObj.AttachmentPoint = acAttachmentPointMiddleCenter
       MTextObj.InsertionPoint = iPt
       Set MTextObj = Nothing
       Dim sPt(0 To 2) As Double
       Dim ePt(0 To 2) As Double
       sPt(0) = 0: sPt(1) = 7: sPt(2) = 0
       ePt(0) = 22: ePt(1) = 7: ePt(2) = 0
       BlockObj.AddLine sPt, ePt
       sPt(0) = 10: sPt(1) = 14: sPt(2) = 0
       ePt(0) = 10: ePt(1) = 7: ePt(2) = 0
       BlockObj.AddLine sPt, ePt
       Set BlockObj = Nothing
End SubSub CreateTable()
       ' 设置当前表格样式
       ThisDrawing.SetVariable "CTABLESTYLE", "明细表"
       Dim MSpaceObj As IAcadModelSpace2
       Set MSpaceObj = ThisDrawing.ModelSpace
       Dim iPt(0 To 2) As Double
       iPt(0) = 0: iPt(1) = 0: iPt(2) = 0
       Dim TableObj As AcadTable
       Set TableObj = MSpaceObj.AddTable(iPt, 2, 8, 7, 10)
       ThisDrawing.SetVariable "CTABLESTYLE", "Standard"
       ' 列标题行，行高为14，其余为7
       TableObj.SetRowHeight 0, 14
       ' 设置列宽
       TableObj.SetColumnWidth 0, 8
       ' 设置单元格文字
       TableObj.SetText 0, 0, "序号"
       TableObj.SetColumnWidth 1, 40
       TableObj.SetText 0, 1, "代   号"
       TableObj.SetColumnWidth 2, 44
       TableObj.SetText 0, 2, "名   称"
       TableObj.SetColumnWidth 3, 8
       TableObj.SetText 0, 3, "数量"
       TableObj.SetColumnWidth 4, 38
       TableObj.SetText 0, 4, "材   料"
       TableObj.SetColumnWidth 5, 10
       TableObj.SetColumnWidth 6, 12
       ' 合并，重量栏
       TableObj.MergeCells 0, 0, 5, 6
       ' 插入块，重理栏
       TableObj.SetBlockTableRecordId 0, 5, ThisDrawing.Blocks("明细表-表头").ObjectID, True
       TableObj.SetCellAlignment 0, 5, acTopCenter
       TableObj.SetColumnWidth 7, 20
       TableObj.SetText 0, 7, "备注"
       ' 数据行
       TableObj.SetText 1, 0, "1"
End Sub

1qyep3mszjp.gif