使用 VBA 删除 powerpoint 上的内容

Question

我有一个每周的演示文稿，我正试图将其自动化。每周我都会删除前几周的所有内容，并使用 excel 中的宏粘贴新数据。但是我不知道如何删除所有以前的内容。注意：我不想删除幻灯片，只是删除幻灯片上的图片。

已编辑：下面是我在 excel 中用于每周粘贴新数据的代码。此代码适用于单张幻灯片。是否可以添加代码以在粘贴新数据之前删除前几周的数据？

Sub PasteAltSummaryToDeck()
'PURPOSE: Copy alt summary page and paste into weekly deck'

Dim myPresentation As Object
Dim mySlide As Object
Dim PowerPointApp As Object
Dim shp As Object
Dim MySlideArray As Variant
Dim MyRangeArray As Variant
Dim x As Long

'Create an Instance of PowerPoint
  On Error Resume Next

'Is PowerPoint already opened?
  Set PowerPointApp = GetObject(class:="PowerPoint.Application")

'Clear the error between errors
  Err.Clear

'If PowerPoint is not already open then Exit
  If PowerPointApp Is Nothing Then
    MsgBox "PowerPoint Presentation is not open, aborting."
    Exit Sub
  End If

'Handle if the PowerPoint Application is not found
  If Err.Number = 429 Then
    MsgBox "PowerPoint could not be found, aborting."
    Exit Sub
  End If

  On Error GoTo 0

'Make PowerPoint Visible and Active
  PowerPointApp.ActiveWindow.Panes(2).Activate

'Create a New Presentation
  Set myPresentation = PowerPointApp.ActivePresentation

'List of PPT Slides to Paste to
  MySlideArray = Array(11)

'List of Excel Ranges to Copy from
    MyRangeArray = Array(Sheet2.Range("F5:AS60"))

'Loop through Array data
  For x = LBound(MySlideArray) To UBound(MySlideArray)
    'Copy Excel Range
        MyRangeArray(x).Copy

'Paste to PowerPoint and position
  On Error Resume Next
    Set shp = myPresentation.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=2) 'Excel 2007-2010
    Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange 'Excel 2013
  On Error GoTo 0

'Center Object
  With myPresentation.PageSetup
    shp.Left = (.SlideWidth \ 2) - (shp.Width \ 2)
    shp.Top = (.SlideHeight \ 2) - (shp.Height \ 2)
  End With

  Next x

   'Record the date & time of procedure execution
    Range("ExportAltSumToPPT").Value = Format(Now(), "mm/dd/yy") & " - " & 
Format(TimeValue(Now), "hh:mm AM/PM")

'Transfer Complete
  Application.CutCopyMode = False
 ThisWorkbook.Activate
  MsgBox "Complete!"


End Sub

Answer 1

试试这个；

    Sub deletepics()

        'variables
        Dim slide As slide
        Dim y As Long

        'loop through slides backwards and with the slides shapes if they are pictures then delete
        For Each slide In ActivePresentation.Slides 
            For y = slide.Shapes.Count To 1 Step -1
                With slide.Shapes(y)
                    If .Type = msoPicture Then
                        .Delete
                    End If
                End With
            Next
        Next

    End Sub

编辑：如果您只想删除幻灯片 14 到 2 上的图像，您可以这样做。忽略我的评论，他们错了。但是下面的代码对你有用。

Sub deletepics()

    'variables
    Dim slide As slide
    Dim y As Long
    'loop through slides backwards and with the slides shapes if they are pictures then delete


For y = ActivePresentation.Slides.Count To 2 Step -1
    If y <> 14 Then
        Set sldTemp = ActivePresentation.Slides(y)
            For lngCount = sldTemp.Shapes.Count To 1 Step -1
                    With sldTemp.Shapes(lngCount)
                        If .Type = msoPicture Then
                            .Delete
                        End If
                    End With
            Next
    End If
Next

End Sub

Answer 2

通过Excel删除幻灯片内容可以使用以下代码：

Option Explicit

Sub remove_previous_shapes_in_PPT()
    Dim sl As PowerPoint.Slide, sl_cnt As Long, pr As Object, pr_name As String, ppt As Object
    Dim i As Long, j As Long
    Set ppt = GetObject(, "PowerPoint.Application")
    Set pr = ppt.Presentations(1)
    sl_cnt = pr.Slides.Count
    For j = sl_cnt To 2 Step -1
        Set sl = pr.Slides(j)
        For i = sl.Shapes.Count To 1 Step -1
            sl.Shapes(i).Delete
        Next i
    Next j
End Sub

这利用遍历幻灯片计数的循环和遍历幻灯片中形状的嵌套循环。在我上面的代码中，我单独保留了幻灯片 1（如果您想删除第一张幻灯片内容，您可以将 j 的循环更改为转到 1，而不是 2）。

注意标记为 as Object 的项目与绑定到 PPT 参考的项目。我没有完成使用您的特定 PPT 的步骤，因为我通常处理 GetObject() 活动 PPT window，只打开 1 个演示文稿。

使用 VBA 删除 powerpoint 上的内容

Deleting content on powerpoint using VBA

excel

powerpoint

vba