如果表格底部超过幻灯片底部，则 Powerpoint 和 VBA 新幻灯片

Question

所以过去几天我一直在努力解决这个问题，我有这个 powerpoint 2007 演示文稿，我使用 VBA 从访问文件中的一个按钮中填充了信息。

在第一张幻灯片中（而且只是现在），我有一个表格可以接收部分信息，但是如果表格超出幻灯片的底部，我不能让表格内容中断到另一张幻灯片，它刚刚超出范围。

我有创建新幻灯片的方法，而且效果很好。但我似乎找不到可以让我开始的例子。

如果确实创建了新幻灯片，我认为我应该检查表格底部是否超过幻灯片底部，剪切重叠单元格并将它们粘贴到新幻灯片中？

提前致谢。

代码示例：

    ' Open PowerPoint
    Dim pptobj As PowerPoint.Application
    Dim Presentation As PowerPoint.Presentation
    Dim oSl as Slide

    Set pptobj = New PowerPoint.Application

    Set pptobj = CreateObject("Powerpoint.Application")
    pptobj.Activate
    Set Presentation = pptobj.Presentations.Open("C:\Users\some.pptx")
    pptobj.Visible = True
    pptobj.WindowState = ppWindowMaximized

    If ((Len(Forms!Some!Name> 0) Then
        pptobj.ActivePresentation.Slides(1).Shapes("TableNome").Table.Cell(1, 1).Shape.TextFrame.TextRange.Text = (CStr(Forms!Some!Name))
    End If

      Set oSl = pptobj.ActivePresentation.Slides(1)

    With oSl
        .Shapes("TableCategory").Table.Cell(1, 1).Shape.TextFrame.TextRange.Text = (CStr(Forms!CVLong!TxtCategory))
        .Shapes("TableEmail").Table.Cell(1, 2).Shape.TextFrame.TextRange.Text = (CStr(Forms!Some!TxtEmail))
        .Shapes("TableData").Table.Cell(1, 2).Shape.TextFrame.TextRange.Text = (CStr(Forms!Some!TxtTlf))
        .Shapes("TableData").Table.Cell(2, 2).Shape.TextFrame.TextRange.Text = (CStr(Forms!Some!TxtCell))
    End With

    Dim oSh as Shape
    Dim overhang        

    Set oSh = pptobj.ActivePresentation.Slides(1).Shapes.AddTable(1, 3, 50, 100, 493)

        'One
    If ((Len(Forms!Some!One)) > 0) Then
        pptobj.ActivePresentation.Slides(1).Shapes("TableInfo").Table.Cell(1, 3).Shape.TextFrame.TextRange.Text = (CStr(Forms!Some!One)) & vbNewLine & vbNewLine
        pptobj.ActivePresentation.Slides(1).Shapes("TableInfo").Table.Cell(1, 1).Shape.TextFrame.TextRange.Text = "One"
    End If

'Two

    If (Len(Forms!Some!Two> 0) Then
        pptobj.ActivePresentation.Slides(1).Shapes("TableInfo").Table.Cell(5, 3).Shape.TextFrame.TextRange.Text = (CStr(Forms!Some!Two)) & vbNewLine
        pptobj.ActivePresentation.Slides(1).Shapes("TableInfo").Table.Cell(5, 1).Shape.TextFrame.TextRange.Text = "Two"
     End If

'Three
    If (Len(Forms!Some!Three) > 0) Then
                pptobj.ActivePresentation.Slides(1).Shapes("TableInfo").Table.Cell(4, 3).Shape.TextFrame.TextRange.Text = (CStr(Forms!Some!Three)) & vbNewLine & vbNewLine
                pptobj.ActivePresentation.Slides(1).Shapes("TableInfo").Table.Cell(4, 1).Shape.TextFrame.TextRange.Text = "Three"
    End If


'Add Slide
    Dim Sld As Slide
    Dim x As Integer
    x = 1

     Set Sld = pptobj.ActivePresentation.Slides.Add(Index:=pptobj.ActivePresentation.Slides.Count + 1, Layout:=ppLayoutBlank)

    For Each Sld In pptobj.ActivePresentation.Slides

        If x >= 2 Then
            pptobj.ActivePresentation.Slides(1).Shapes("Text Placeholder 15").Copy
            pptobj.ActivePresentation.Slides(x).Shapes.Paste
            pptobj.ActivePresentation.Slides(x).Shapes("Text Placeholder 15").ZOrder msoSendToBack
            pptobj.ActivePresentation.Slides(x).Shapes("Text Placeholder 15").Height = 810
            pptobj.ActivePresentation.Slides(x).Shapes("Text Placeholder 15").Top = 19
        End If
    x = x + 1
    Next

End If

  'Put table top border
Dim n As Integer
Dim r As Integer
n = 3
r = 1

While r <= n
        If Len(pptobj.ActivePresentation.Slides(1).Shapes("TableInfo").Table.Cell(r, 3).Shape.TextFrame.TextRange.Text) > 0 Then
            pptobj.ActivePresentation.Slides(1).Shapes("TableInfo").Table.Cell(r, 3).Borders(ppBorderTop).Visible = msoTrue
            pptobj.ActivePresentation.Slides(1).Shapes("TableInfo").Table.Cell(r, 3).Borders(ppBorderTop).ForeColor.RGB = RGB(220, 105, 0)
        Else
            pptobj.ActivePresentation.Slides(1).Shapes("TableInfo").Table.Rows(r).Delete
            n = n - 1
            r = r - 1
        End If
        r = r + 1
Wend

'Add Photo
    pptobj.ActivePresentation.Slides(1).Shapes.AddPicture(FileName:="\\someplace\" & [Id] & ".jpg", linktofile:=mostrue, savewithdocument:=msoTrue, Left:=52, Top:=115).Select

    With pptobj.ActivePresentation.Slides(1).Shapes("Picture 7")
        .LockAspectRatio = msoTrue
        .Width = 85
        .Left = 38
        .Top = 80
    End With

'add footer
    Dim page As Integer
    page = 1
    Dim s As Slide

     For Each s In pptobj.ActivePresentation.Slides
         On Error Resume Next
         Set oSh = s.HeadersFooters.Footer
             If Err.Number <> 0 Then
                 Call s.Master.Shapes.AddPlaceholder(ppPlaceholderFooter, 219, 805, 342, 19)
             End If
        On Error GoTo 0
            s.HeadersFooters.Footer.Visible = msoTrue
            s.HeadersFooters.Footer.Text = (CStr(Forms!Some!Name)) & " - Page " & page & " of " & pptobj.ActivePresentation.Slides.Count
            page = page + 1
    Next    

Answer 1

下面的代码 sn -p 可能会给你一些启发。现在它只是确定表太大并给你一条消息。如果没有关于数据类型以及如何获取数据的更多信息，就很难回答问题的第二部分。您很可能会创建一个表，一次添加一行并检查表的大小；当表格变得太大（或距底部一定距离内）时，您创建一张新幻灯片并继续该过程。这可能比创建一个太大的表格，然后试图找出在哪里切割它要好。

代码如下：

Sub createTable()
Dim oSl As Slide
Dim oSh As Shape
Dim overhang

Set oSl = ActivePresentation.Slides(1)
Set oSh = oSl.Shapes.AddTable(28, 3)

overhang = ActivePresentation.PageSetup.SlideHeight - (oSh.Height + oSh.Top)

If overhang > 0 Then
  MsgBox "the table fits"
Else
  MsgBox "the table is too big!"
End If

End Sub