将幻灯片移动到 powerpoint 中某个部分的开头的 VBA 代码

Question

我有一个 Excel 宏，可以根据工作簿中的工作表创建一个 Powerpoint。一切都很好地转移到了 powerpoint，但我在弄清楚如何使用 vba 将幻灯片移动到各个部分时遇到问题。例如，我只想将幻灯片 1 移至第 1 部分，将幻灯片 2 移至第 2 部分，依此类推。下面是我当前的代码。谢谢。

Sub ExporttoPPT()

Dim ppt_app As New PowerPoint.Application
Dim pre As PowerPoint.Presentation
Dim slde As PowerPoint.Slide
Dim shp As PowerPoint.Shape
Dim wb As Workbook
Dim rng As Range

Dim vSheet$
Dim vRange$
Dim vWidth As Double
Dim vHeight As Double
Dim vTop As Double
Dim vLeft As Double
Dim vSlide_No As Long
Dim expRng As Range

Dim adminSh As Worksheet
Dim cofigRng As Range
Dim xlfile$
Dim pptfile$
Dim a As Integer
Dim SecNum As Integer

Application.DisplayAlerts = False


Set adminSh = ThisWorkbook.Sheets("Admin")
Set cofigRng = adminSh.Range("Rng_sheets1")

xlfile = adminSh.[excelPth]
pptfile = adminSh.[pptPth]

Set wb = Workbooks.Open(xlfile)
   
Set pre = ppt_app.Presentations.Open(pptfile)

Do While pre.Slides.Count > 1
    pre.Slides(2).Delete
Loop

For Each rng In cofigRng

a = a + 1 'Used as counter in loop to increase the slide number in line below.

Set slde = pre.Slides.Add(a, ppLayoutBlank) 'Generates Slides on-demand using verible "a" as slide number
    
    '--------------------------- set VARIABLES
On Error GoTo ErrorHandling 'When error occurs due to blank rows in range code jumps to ErrorHandling and resumes code.
    
    With adminSh
        vSheet$ = .Cells(rng.Row, 4).Value
        vRange$ = .Cells(rng.Row, 5).Value
        vWidth = .Cells(rng.Row, 6).Value
        vHeight = .Cells(rng.Row, 7).Value
        vTop = .Cells(rng.Row, 8).Value
        vLeft = .Cells(rng.Row, 9).Value
        vSlide_No = .Cells(rng.Row, 10).Value
    End With

        
        '-----------------------------EXPORT TO PPT
 
                wb.Activate
                Sheets(vSheet$).Activate
                Set expRng = Sheets(vSheet$).Range(vRange$)
                expRng.Copy
    
                Set slde = pre.Slides(vSlide_No)
                slde.Shapes.PasteSpecial ppPasteBitmap
                Set shp = slde.Shapes(1)
    
                With shp
    
                    .Top = vTop
                    .Left = vLeft
                    .Width = vWidth
                    .Height = vHeight
        
                End With
    
    
                Set shp = Nothing
                Set slde = Nothing
                Set expRng = Nothing
    
    Application.CutCopyMode = False
    Set expRng = Nothing
Next rng

ErrorHandling:

pre.Slides(a).Delete 'Deletes last blank slide

pre.Slides(1).MoveToSectionStart "Section 1" 'This is the area I need help with.

'pre.Save
'pre.Close

Set pre = Nothing
Set ppt_app = Nothing
wb.Close False
Set wb = Nothing

Application.DisplayAlerts = True



End Sub

Answer 1

请尝试一下。

Option Explicit
Sub demo()
    Dim ppt As Presentation, i As Integer
    Dim iLoc As Integer, sld As Slide
    Const SEC_NAME = "Section 2"
    Set ppt = ActivePresentation
    For i = 1 To ppt.SectionProperties.Count
        ' Get Section Index by name
        If ppt.SectionProperties.Name(i) = SEC_NAME Then
            ' Move slides
            ppt.Slides(2).MoveToSectionStart i
            ppt.Slides(1).MoveToSectionStart i
        End If
    Next
End Sub