Powerpoint和VBA新的幻燈片，如果表底部超過了幻燈片的底部

所以我一直在努力與這個過去幾天，我有這個PowerPoint演示文稿，我填充信息從一個按鈕從一個訪問文件使用VBA。Powerpoint和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

來源

2013-04-01 NelsonFerro

這是什麼意思：「我在使用VBA一個**訪問文件填滿來自**的一個按鈕信息，從」？您能否顯示迄今獲得數據和創建表格的代碼 - 以及您試圖確定表格太大的原因？ – Floris

我懷疑在第一張幻燈片上創建一個表格並且每次添加一行數據會比較容易，在每行添加後檢查表格形狀的高度。如果該值位於幻燈片高度的安全範圍內，請添加一張新幻燈片，向其中添加一個表格並繼續將數據添加到新表格。 –

一種你對夫婦的其他資源從PPT FAQ網站我維護：http://www.pptfaq.com/FAQ00892_Using_Excel_and_Access_data_in_PowerPoint_Tables_-by_Brian_Reilly_and_Naresh_Nichani-.htm和http://www.pptfaq.com/FAQ00795_Controlling_Office_Applications_from_PowerPoint_-by_Naresh_Nichani_and_Brian_Reilly-.htm –

下面的代碼片段可以給你一些啓示。現在它只是確定該表太大，並給你一個消息。如果沒有關於數據類型和獲得方式的更多信息，很難對問題的第二部分給出答案。很可能你會創建一個表，每次添加一行並檢查表的大小;當表格變得太大（或距底部一定距離內）時，您將創建一個新幻燈片並繼續該過程。這可能比創建一個太大的表更好，然後試圖找出將其切割的位置。

下面是代碼：

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

來源

2013-04-01 16:14:35 Floris

Powerpoint和VBA新的幻燈片，如果表底部超過了幻燈片的底部

回答

相關問題