powerpoint VBA 代码 - 将形状大小和位置链接到文本表动态内容

Question

我正在尝试创建一个包含 2 列的文本表， 在列之间添加垂直线形状， 每行有不同颜色的线， 并确保当您向表格添加文本时，行的长度会根据行高而变化。

我查找了几个选项，并尝试使用VBA。

这就是 Chat GPT 的想法：

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 不接受“.Top”命令。

我收到编译错误：

未找到方法或数据成员

并且 .Top 在这一行中以红色突出显示：

' 获取表格顶部位置 桌面 = tbl.Top

关于如何解决这个问题有什么建议吗？

Answer 1

尝试使用 Shape 对象的 Top 方法...

tableTop = tbl.Parent.Top

或

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

Answer 2

好的，这是一个可以做你想做的事的例程 - 如果我明白你想要什么......

不限于精确7行2列的表格。如果您的表格超过 7 行，颜色将会重复。

要计算位置，您需要作为表格容器的形状的 left/top 属性，然后使用列的宽度和行的高度属性（并将它们相加）。

我已经实现了一种逻辑，即线条将由（形状）名称来标识。如果您有一个名为

Table1

的表，则这些行的名称应类似于

Table_Line_1_1

。如果找不到具有该名称的行，则会动态创建该行。 注意：不可能使用代码定义圆形大写字母，微软太懒了，无法实现这一点 - 您需要手动执行此操作。

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

好的，现在一些小例程来触发该例程。

o 一张用于 all 幻灯片的 all 表格 (

UpdateAllSlides

)
o 一张幻灯片适用于所有表 (

UpdateAllSlideTables

)
o 一个用于当前幻灯片的所有表格 (

UpdateCurrentSlide

)
o 一个用于选定的表 (

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

这里有一个 5x3 桌子的示例： 没有线条开始：

第一次运行宏将创建线条，但没有圆形大写字母（看起来有点奇怪）

如上所述，您需要手动设置线帽

现在修改表格（输入新文本、调整列宽...）

...然后再次运行宏