vba - Powerpoint & VBA テーブルの下部がスライドの下部を超える場合の新しいスライド

Question

だから私は過去数日間これに苦労してきました.VBAを使用してアクセスファイルのボタンから情報を入力するこのPowerPoint 2007プレゼンテーションがあります。

そして、最初のスライド（そして今のところ）には、情報の一部を受け取るテーブルがありますが、テーブルがスライドの下部を超えた場合、テーブルのコンテンツを別のスライドに分割することはできません。範囲の。

新しいスライドを作成する方法があり、それはうまくいきます。しかし、私を始めることができる例が見つからないようです。

新しいスライドを作成する場合は、テーブルの下部がスライドの下部を超えていることを確認し、重複するセルを切り取って新しいスライドに貼り付けるようなものにする必要があると思いますか?

前もって感謝します。

コード例:

    ' 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