PowerPoint VBA select 幻灯片

Question

我的目标是通过VBA创建ppt。我的桌面上已经有我需要使用的模板。这部分代码没问题

但是我没有找到如何在ppt中select幻灯片。我尝试了很多方法，但总是出错。

如果有人能帮助我。

Option Explicit

Sub CreatePowerPoint()

Dim mySlide As PowerPoint.Slide
Dim myShapeRange As PowerPoint.Shape

Dim oPA As PowerPoint.Application
Dim oPP As PowerPoint.Presentation
Dim oPS As PowerPoint.SlideRange
Dim strTemplate As String
Dim rng As Range

strTemplate = "C:\Users0866\Desktop\vba\PPT\Template.potx"

Set oPA = New PowerPoint.Application
oPA.Visible = msoTrue
oPA.Presentations.Open strTemplate, untitled:=msoTrue

If Not oPS Is Nothing Then Set oPS = Nothing
If Not oPP Is Nothing Then Set oPP = Nothing
If Not oPA Is Nothing Then Set oPA = Nothing


Err_PPT:
If Err <> 0 Then
MsgBox Err.Description
Err.Clear
Resume Next
End If

Set rng = ThisWorkbook.Sheets("Credit Recommendation").Range("B2:N59")

ActivePresentation.Slides (1)
  rng.Copy
mySlide.Shapes.PasteSpecial (ppPasteBitmap)
  Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)
myShapeRange.LockAspectRatio = msoFalse
      myShapeRange.Left = 20
      myShapeRange.Top = 80
      myShapeRange.Height = 400
 myShapeRange.Width = 680
  Application.CutCopyMode = False


End Sub

谢谢！！！

Answer 1

这是您修改后可以正常工作的代码。我在下面解释修改

Option Explicit

Sub CreatePowerPoint()
    Dim mySlide As PowerPoint.Slide
    Dim myShapeRange As PowerPoint.Shape
    
    Dim oPA As PowerPoint.Application
    Dim oPP As PowerPoint.Presentation
    Dim oPS As PowerPoint.SlideRange
    Dim strTemplate As String
    Dim rng As Range
    
    strTemplate = "C:\Users0866\Desktop\vba\PPT\Template.potx"
    
    Set oPA = New PowerPoint.Application
    oPA.Visible = msoTrue
    'changed this line to assign the new presentation to your variable
    Set oPP = oPA.Presentations.Open(strTemplate, untitled:=msoTrue)
    
    
    'If Not oPS Is Nothing Then Set oPS = Nothing
    'If Not oPP Is Nothing Then Set oPP = Nothing
    'If Not oPA Is Nothing Then Set oPA = Nothing
    
Err_PPT:
    If Err <> 0 Then
    MsgBox Err.Description
    Err.Clear
    Resume Next
    End If
    
    Set rng = ThisWorkbook.Sheets("sheet1").Range("B2:N59")
    
    Set mySlide = oPP.Slides(1)
    rng.Copy
    mySlide.Shapes.PasteSpecial (ppPasteBitmap)
    Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)
        myShapeRange.LockAspectRatio = msoFalse
        myShapeRange.Left = 20
        myShapeRange.Top = 80
        myShapeRange.Height = 400
        myShapeRange.Width = 680
    Application.CutCopyMode = False
End Sub

您在声明变量时从未将它们设置为等于任何值。我仍然没有看到 oPS 在哪里使用过。

您收到 ActiveX 错误，因为 PowerPoint 没有活动的演示文稿。使用您自己的对象总是比在 Office 中使用 ActiveAnything 更安全。所以我将 oPP 设置为等于您的新演示文稿，然后使用 oPP 而不是 ActivePresentation

此外，除非您对它发生的顺序很挑剔，否则您永远不需要将其设置为无。在 Sub 中声明的所有内容在 sub 的末尾都设置为空。

希望对您有所帮助！

编辑：搜索和替换

This 是我获得代码的地方，但我将其修改为可调用的 Sub，因为我多次从不同的地方调用它：

'Find and Replace function
Sub FindAndReplace(sFind As String, sReplace As String, ByRef ppPres As PowerPoint.Presentation)
    Dim osld As PowerPoint.Slide
    Dim oshp As PowerPoint.Shape
    Dim otemp As PowerPoint.TextRange
    Dim otext As PowerPoint.TextRange
    Dim Inewstart As Integer
    
    For Each osld In ppPres.Slides
        For Each oshp In osld.Shapes
            If oshp.HasTextFrame Then
                If oshp.TextFrame.HasText Then
                    Set otext = oshp.TextFrame.TextRange
                    Set otemp = otext.Replace(sFind, sReplace, , msoFalse, msoFalse)
                    Do While Not otemp Is Nothing
                        Inewstart = otemp.Start + otemp.Length
                        Set otemp = otext.Replace(sFind, sReplace, Inewstart, msoFalse, msoFalse)
                    Loop
                End If
            End If
        Next oshp
    Next osld
End Sub

您必须将 2 个字符串和 Presentation 对象传递给它。它在你的 Sub

中看起来像这样

FindAndReplace("FindMe","ReplaceWithThis", oPP)

PowerPoint VBA select 幻灯片

PowerPoint VBA select slide

powerpoint

vba

编辑：搜索和替换