Link shape size and position to a text table dynamic content

Question

I'm trying to create a text table with 2 columns,
add a vertical line shape between the columns,
each row with a different color line,
and make it so when you add text to the table the length of the line changes according to the row height.

This is what ChatGPT came up with:

Sub UpdateLineShapes()
    Dim slide As slide
    Dim tbl As Table
    Dim shp As Shape
    Dim rowNum As Integer
    Dim lineColors(1 To 7) As Long
    Dim lineWidth As Single
    Dim lineHeight As Single
    Dim lineTop As Single
    Dim tableTop As Single
    Dim rowHeight As Single

    ' Define the slide containing the table and line shapes
    Set slide = ActivePresentation.Slides(1) ' Change slide index as needed

    ' Define the table containing the data
    Set tbl = slide.Shapes("Table 1").Table ' Change the name of the table shape as needed

    ' Define the predetermined line colors
    lineColors(1) = RGB(255, 0, 0) ' Red
    lineColors(2) = RGB(0, 255, 0) ' Green
    lineColors(3) = RGB(0, 0, 255) ' Blue
    lineColors(4) = RGB(255, 255, 0) ' Yellow
    lineColors(5) = RGB(255, 0, 255) ' Magenta
    lineColors(6) = RGB(0, 255, 255) ' Cyan
    lineColors(7) = RGB(128, 128, 128) ' Gray

    ' Get the top position of the table
    tableTop = tbl.Top

    ' Loop through each row in the table
    For rowNum = 1 To 7 ' Assuming there are 7 rows
        ' Define the line shape corresponding to the row
        Set shp = slide.Shapes("Line" & rowNum) ' Assuming line shapes are named "Line1", "Line2", etc.

        ' Preset line width
        lineWidth = 2 ' Fixed line width (Modify as needed)

        ' Calculate line height based on row height and subtract 0.4 cm
        rowHeight = tbl.Rows(rowNum).Height - 0.4 * 28.35 ' Convert 0.4 cm to points (1 cm = 28.35 points)

        ' Calculate top position of the line shape to align it to the middle of the row
        lineTop = tableTop + tbl.Rows(1).Top + (rowHeight / 2) + (rowHeight * (rowNum - 1))

        ' Update line properties
        With shp.Line
            ' Assign predetermined line color
            .ForeColor.RGB = lineColors(rowNum)
            .Weight = lineWidth
            ' Adjust line length to match calculated height
            shp.Height = rowHeight
            ' Set the top position to align the line to the middle of the row
            shp.Top = lineTop
        End With
    Next rowNum
End Sub

VBA is not accepting the .Top command.

I get a compile error:

Method or data member not found

and .Top is highlighted in red in this line:

' Get the top position of the table
tableTop = tbl.Top

Answer 1

Try the Top method of the Shape object instead...

tableTop = tbl.Parent.Top

or

tableTop = slide.Shapes("Table 1").Top

Answer 2

Okay, here is a routine that will do what you want - if I understood what you want...

It is not limited to tables with exact 7 rows and 2 columns. If you have a table with more than 7 rows, the colors will repeat.

To calculate the position, you need the left/top properties of the shape that is the container of the table, and then use the width of the columns and the height properties of the rows (and add them up).

I have implemented a logic that the lines will be identified by (shape-)name. If you have a table named Table1, the lines are expected to have a name like Table_Line_1_1. If a line with that name cannot be found, it is created on the fly. Note: It is not possible to define round caps using code, Microsoft was too lazy to implement this - you will need to do this manually.

Sub UpdateLineShapes(sl As slide, sh As Shape)
    ' Set the following values as you want.
    Const Margin = 12
    Const LineWidth = 12
    
    ' Define the predetermined line colors
    Dim lineColors(1 To 7) As Long
    lineColors(1) = RGB(255, 0, 0) ' Red
    lineColors(2) = RGB(0, 255, 0) ' Green
    lineColors(3) = RGB(0, 0, 255) ' Blue
    lineColors(4) = RGB(255, 255, 0) ' Yellow
    lineColors(5) = RGB(255, 0, 255) ' Magenta
    lineColors(6) = RGB(0, 255, 255) ' Cyan
    lineColors(7) = RGB(128, 128, 128) ' Gray
    
    If sh.Type <> msoTable Then Exit Sub 
    
    With sh.table
        Dim rowNum As Long, colNum As Long
        Dim top As Double
        top = sh.top
        For rowNum = 1 To .Rows.Count
            Dim left As Double
            left = sh.left
            For colNum = 1 To .Columns.Count - 1
                left = left + .Columns(colNum).Width
                Dim line As Shape
                Set line = getline(sl, sh.Name, rowNum, colNum)
                line.left = left

                line.top = top + Margin
                line.Height = .Rows(rowNum).Height - (2 * Margin)
                line.line.Weight = LineWidth
                
                Dim colorIndex As Long
                colorIndex = (rowNum - 1) Mod UBound(lineColors) + 1
                line.line.ForeColor.RGB = lineColors(colorIndex)
                
            Next colNum
            top = top + .Rows(rowNum).Height
        Next rowNum
    End With
End Sub


Function getline(sl As slide, prefix As String, rowNum As Long, colNum As Long) As Shape
    Dim line As Shape, lineName As String
    lineName = prefix & "_Line_" & rowNum & "_" & colNum
    On Error Resume Next
    Set line = sl.Shapes(lineName)
    On Error GoTo 0
    If line Is Nothing Then
        Set line = sl.Shapes.AddConnector(msoConnectorStraight, 100, 100, 100, 200)
        line.Name = lineName
    End If
    Set getline = line
End Function

Okay, now some small routines to trigger that routine.

o One for all tables of all slide (UpdateAllSlides)
o One for all tables of a slide (UpdateAllSlideTables)
o One for all tables of the current slide (UpdateCurrentSlide)
o One for a selected table (UpdateSelection)

Sub UpdateAllSlides()
    Dim sl As slide
    For Each sl In ActivePresentation.Slides
        UpdateAllSlideTables sl
    Next
End Sub

Sub UpdateCurrentSlide()
    UpdateAllSlideTables Application.ActiveWindow.View.slide
End Sub

Sub UpdateAllSlideTables(sl As slide)
    Dim sh As Shape
    For Each sh In sl.Shapes
        If sh.Type = msoTable Then
            UpdateLineShapes sl, sh
        End If
    Next
End Sub

Sub UpdateSelection()
    Dim sh As Shape
    For Each sh In ActiveWindow.Selection.ShapeRange
        If sh.Type = msoTable Then
            UpdateLineShapes sh.Parent, sh
        End If
    Next
End Sub

Here an example with a 5x3 table: Starting without lines:

Running the macro for the first time will create the lines, but without round caps (looks kind of weird)

As said, you will need to set the line caps manually

Now modify the table (enter new text, resize column width...)

...and run the macro again