[分享]运用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 好！学习中 cAD2004的可以吗？
怎么做修改，我想用此程序做我的标题栏 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)
我把这段代码拿来调试，提示错误：系统注册表中不存在 AcRxClassName 项。
这个该怎么解决 ？望指点 谢谢分享太有用了
页:
[1]