Option Explicit
Sub Test_MergeCells()
Dim r As Long
Dim c As Long
Dim oSpace As AcadBlock
If ThisDrawing.ActiveSpace = acModelSpace Then
Set oSpace = ThisDrawing.ModelSpace
Else
Set oSpace = ThisDrawing.PaperSpace
End If
Dim pt(2) As Double
Dim acol As New AcadAcCmColor
Dim oTable As AcadTable
Set oTable = oSpace.AddTable(pt, 21, 13, 800, 1000)
With oTable
.RegenerateTableSuppressed = True
.DeleteRows 0, 2
.FlowDirection = acTableTopToBottom
.HorzCellMargin = 50#
.VertCellMargin = 50#
.SetTextHeight AcRowType.acDataRow + AcRowType.acTitleRow + AcRowType.acHeaderRow, 250#
.MergeCells 0, 2, 0, 0
.SetColumnWidth 0, 1000#
.SetCellAlignment 0, 0, acMiddleCenter
.SetText 0, 0, "SR. NO."
.MergeCells 0, 2, 1, 1
.SetColumnWidth 1, 3000#
.SetCellAlignment 0, 1, acMiddleCenter
.SetText 0, 1, "BEND. NO."
.MergeCells 0, 2, 2, 2
.SetColumnWidth 2, 2500#
.SetCellAlignment 0, 2, acMiddleCenter
.SetText 0, 2, "CENTER LINE EL."
.MergeCells 0, 0, 3, 5
.SetColumnWidth 3, 2600#
.SetCellAlignment 0, 3, acMiddleCenter
.SetText 0, 3, "DEFLECTION ANGLE."
.MergeCells 1, 1, 3, 4
.SetColumnWidth 4, 2750#
.SetCellAlignment 1, 3, acMiddleCenter
.SetText 1, 3, "IN ELEVATION."
.MergeCells 1, 2, 5, 5
.SetColumnWidth 4, 2900#
.SetCellAlignment 1, 5, acMiddleCenter
.SetText 1, 5, "IN PLAN ""C"""
.SetCellAlignment 2, 3, acMiddleCenter
.SetText 2, 3, "ON US ""A"""
.SetCellAlignment 2, 4, acMiddleCenter
.SetText 2, 4, "ON DS ""B"""
.MergeCells 0, 2, 6, 6
.SetColumnWidth 6, 2900#
.SetCellAlignment 0, 6, acMiddleCenter
.SetText 0, 6, "TRUE ANGLE (FOR FABRICATION) ""0"""
.MergeCells 0, 2, 7, 7
.SetColumnWidth 7, 1950#
.SetCellAlignment 0, 7, acMiddleCenter
.SetText 0, 7, "TANGENT LENGTH ""T"""
.MergeCells 0, 2, 8, 8
.SetColumnWidth 8, 2100#
.SetCellAlignment 0, 8, acMiddleCenter
.SetText 0, 8, "PIPE DIA AT BEND ""D2"""
.MergeCells 0, 2, 9, 9
.SetColumnWidth 9, 1950#
.SetCellAlignment 0, 9, acMiddleCenter
.SetText 0, 9, "BEND RADIUS ""R"""
.MergeCells 0, 2, 10, 10
.SetColumnWidth 10, 1950#
.SetCellAlignment 0, 10, acMiddleCenter
.SetText 0, 10, """N"" NO OF SEGMENTS EACH OF 6'"
.MergeCells 0, 2, 11, 11
.SetColumnWidth 11, 3150#
.SetCellAlignment 0, 11, acMiddleCenter
.SetText 0, 11, "TWO END SEGMENTS EACH OF ANGLE ""A"""
.MergeCells 0, 2, 12, 12
.SetColumnWidth 12, 3150#
.SetCellAlignment 0, 12, acMiddleCenter
.SetText 0, 12, "NO. OF STIFFNER RINGS"
acol.ColorIndex = 122
For r = 0 To 2
For c = 0 To 12
.SetCellContentColor r, c, acol
Next
Next
For r = 3 To 18
.SetCellAlignment r, 0, acMiddleCenter
.SetText r, 0, CStr(r - 2) & "."
Next
.RegenerateTableSuppressed = False
End With
ZoomExtents
End Sub
