Hinzufügen eines benutzerdefinierten Folienlayouts in PowerPoint mithilfe von Excel VBA?

Question

Ich habe eine PowerPoint mit benutzerdefinierten Folienlayouts erstellt. Ich möchte eine neue Folie mit einem dieser benutzerdefinierten Layouts mit Excel VBA erstellen können, aber ich kann nicht die richtige Syntax herausfinden.

Dies ist der Code, den ich derzeit haben:

Sub runPPT() 

Application.ScreenUpdating = False 

Dim wb As Workbook 
Set wb = ThisWorkbook 

Dim ws As Worksheet 
Set ws = wb.Sheets("SG2") 

Dim pptName As String 
Dim ppt As Object 
Dim myPres As Object 
Dim slds As Object 
Dim sld As Object 

MsgBox ("Please choose PowerPoint to open.") 
pptName = openDialog() 
Set ppt = CreateObject("PowerPoint.Application") 
Set myPres = ppt.Presentations.Open(pptName) 

Set slds = myPres.Slides 
'This is where I want to add my custom layout 
'My layouts all have similar names like "Gate 2 Main" if that helps 
Set sld = slds.AddSlides(Slides.Count + 1, ActivePresentation.SlideMaster.CustomLayouts(1)) 

Application.ScreenUpdating = True 
End Sub 


Private Function openDialog() 
Dim fd As Office.FileDialog 
Dim txtFileName As String 
Set fd = Application.FileDialog(msoFileDialogFilePicker) 
With fd 
    .AllowMultiSelect = False 
    ' Set the title of the dialog box. 
    .Title = "Please select the file." 

    ' Clear out the current filters, and add our own. 
    .Filters.Clear 

    ' Show the dialog box. If the .Show method returns True, the 
    ' user picked at least one file. If the .Show method returns 
    ' False, the user clicked Cancel. 
    If .Show = True Then 

    txtFileName = .SelectedItems(1) 'replace txtFileName with your textbox 

    End If 

End With 

openDialog = txtFileName 

End Function 

Answer 1

ich mein Problem beheben konnte durch meinen Code auf die folgende Veränderung:

Sub runPPT() 

    Application.ScreenUpdating = False 

    Dim wb As Workbook 
    Set wb = ThisWorkbook 

    Dim ws As Worksheet 
    Set ws = wb.Sheets("SG2") 

    Dim pptName As String 
    Dim ppt As PowerPoint.Application 
    Dim myPres As PowerPoint.Presentation 
    Dim slds As PowerPoint.Slides 
    Dim sld As PowerPoint.slide 

    Dim oLayout As CustomLayout 

    MsgBox ("Please choose PowerPoint to open.") 
    pptName = openDialog() 
    Set ppt = CreateObject("PowerPoint.Application") 
    Set myPres = ppt.Presentations.Open(pptName) 

    Set slds = myPres.Slides 
    Set sld = slds.Add(myPres.Slides.Count + 1, ppLayoutBlank) 

    For Each oLayout In myPres.Designs("Gate Main").SlideMaster.CustomLayouts 
     If oLayout.Name = "Gate 2 Main" Then 
      sld.CustomLayout = oLayout 
      Exit For 
     End If 
    Next 

    Application.ScreenUpdating = True 

End Sub 


Private Function openDialog() 

    Dim fd As Office.FileDialog 

    Dim txtFileName As String 

    Set fd = Application.FileDialog(msoFileDialogFilePicker) 

    With fd 

    .AllowMultiSelect = False 

    ' Set the title of the dialog box. 
    .Title = "Please select the file." 

    ' Clear out the current filters, and add our own. 
    .Filters.Clear 

    ' Show the dialog box. If the .Show method returns True, the 
    ' user picked at least one file. If the .Show method returns 
    ' False, the user clicked Cancel. 
    If .Show = True Then 

     txtFileName = .SelectedItems(1) 'replace txtFileName with your textbox 

    End If 

    End With 

    openDialog = txtFileName 

End Function