如果桌面超出幻灯片的底部，则Powerpoint和VBA新幻灯片

所以我在过去几天一直在努力解决这个问题，我有这个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