PowerPoint VBA選擇幻燈片

Question

我的目標是通過VBA創建ppt。 我的桌面上已經有需要使用的模板。 這部分代碼還可以。

但是我沒有找到如何在ppt中選擇幻燈片。 我嘗試了很多方法，但總是出錯。

如果有人可以幫助我。

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:\Users\290866\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:\Users\290866\Desktop\vba\PPT\Template.potx"

    Set oPA = New PowerPoint.Application
    oPA.Visible = msoTrue
    'changed this line to assign the new presentation to your varriable
    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而不是ActivePresentaiton

同樣，除非您對事件發生的順序有所挑剔，否則您永遠不需要將事物設置為等於零。 Sub中聲明的所有內容在Sub的末尾都設置為空。

希望這可以幫助！

編輯：搜索和替換

這是我獲得代碼的地方，但是我對其進行了修改，以用作可調用的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)