Request - Macro to populate tables with text

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53

Sub table_test_01()
Dim s As Shape
Dim lngColCounter As Long
Dim lngRowCounter As Long
Const lngNumColumns As Long = 20
Const lngNumRows As Long = 12

    On Error GoTo ErrHandler
    
    EventsEnabled = False
    Optimization = True
    ActiveDocument.BeginCommandGroup "some table stuff"
    
    If JQ_create_table(s, ActiveLayer, 1, 1, 16, 10, lngNumColumns, lngNumRows) Then
        'table created successfully
        For lngColCounter = 1 To lngNumColumns
            For lngRowCounter = 1 To lngNumRows
                s.Custom.cell(lngColCounter, lngRowCounter).TextShape.Text.Story = "X"
                s.Custom.cell(lngColCounter, lngRowCounter).TextShape.Text.Story.Size = 24
                s.Custom.cell(lngColCounter, lngRowCounter).TextShape.Text.Story.Alignment = cdrCenterAlignment
                s.Custom.cell(lngColCounter, lngRowCounter).TextShape.Text.Frame.VerticalAlignment = cdrCenterJustify
            Next lngRowCounter
        Next lngColCounter
    Else
        MsgBox "Table creation failed."
    End If
        
ExitSub:
    ActiveDocument.EndCommandGroup
    Optimization = False
    EventsEnabled = True
    Refresh
    Exit Sub
    
ErrHandler:
    MsgBox "Error occurred: " & Err.Description
    Resume ExitSub
End Sub

Function JQ_create_table(ByRef CreatedTable As Shape, ByVal Layer As Layer, ByVal LeftX As Double, ByVal BottomY As Double, ByVal RightX As Double, ByRef TopY As Double, ByRef NumColumns As Long, ByRef NumRows As Long) As Boolean

    On Error GoTo ErrHandler
    
    Set CreatedTable = Layer.CreateCustomShape("Table", LeftX, BottomY, RightX, TopY, NumColumns, NumRows)
    JQ_create_table = True

ExitFunc:
    Exit Function
    
ErrHandler:
    MsgBox "Error occurred: " & Err.Description & vbCrLf & vbCrLf & "JQ_create_table()"
    Resume ExitFunc
End Function