VBA – 从Excel中，拉PPT模板（potx），并使用模板customlyout？

我一直在使用Excel创buildPowerPoint幻灯片使用.potx文件作为PowerPoint模板摔跤。

我有的问题是，我无法弄清楚如何复制slidemaster，所以我可以使用自定义布局。

我想创build一个使用.potx文件中定义的布局的新演示文稿？

我是全新的VBA，所以我的代码有点粗糙的边缘。

Sub ExcelRangeToPowerPoint() 'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation 'SOURCE: www.TheSpreadsheetGuru.com Dim PowerPointApp As Object Dim myPresentation As Object Dim mySlide As Object Dim myShape As Object Dim mytextbox As Object Dim Ws As Worksheet Dim trueranges As New Collection 'Store the ranges to be used in master excel file Dim start_counting_from_this_row_number As Integer 'starting value of rows to search for TRUE/FALSE Dim worksheetnames As New Collection 'collect all worksheet names if TRUE Dim rg As Range Const PXLtoINCH As Single = 72# 'PP uses pixels not inches, this is the conversion factor Dim SQPOSITION As Double Dim SQHeight As Double Dim range_shape As New WSOrgDisplayAttributes Dim all_data As New Collection '******************************************************************************************************************* 'Check to see if Master Data Sheet Spreadsheet is in same directory and if so, open it. Dim FilePath As String Dim FileNameOnly As String FileNameOnly = "WS Asset Availability Master Data Spreadsheet.xlsx" FilePath = ActiveWorkbook.Path & "\" & FileNameOnly If IsFile(FilePath) = True Then 'ENDIF is near the end of the SUB If CheckFileIsOpen(FileNameOnly) = False Then Workbooks.Open (FileName) MsgBox ("A small time Delay...(This ensures file is open and ready for use") Application.Wait (Now + TimeValue("00:00:10")) 'this allows time to open before other parts of macro run End If '******************************************************************************************************************* '******************************************************************************************************************* '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 open PowerPoint If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(Class:="PowerPoint.Application") '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 'Optimize Code Application.ScreenUpdating = False 'Create a New Presentation Set myPresentation = PowerPointApp.Presentations.Add myPresentation.ApplyTemplate (ThisWorkbook.Path & "\" & "SRR Template.potx") 'myPresentation.ApplyTemplate (FilePath & "\" & "SRR Template.potx") '******************************************************************************************************************* '******************************************************************************************************************* 'Initialize variables start_counting_from_this_row_number = 3 'Find row where first TRUE/FALSE is under column "D" Set rg = ThisWorkbook.Sheets("SRR Helper").Range("D1").CurrentRegion 'count the max rows SQPOSITION = 6 'inches SQHeight = 0.18 'inches '******************************************************************************************************************* '******************************************************************************************************************* 'Push all TRUE's to collections 'ADD HEADER INFO LATER For x = start_counting_from_this_row_number To rg.Rows.Count If ThisWorkbook.Sheets("SRR Helper").Range("D" & x).Value = True Then Set range_shape = Nothing range_shape.let_range_check = True range_shape.let_shape_range = ThisWorkbook.Sheets("SRR Helper").Range("C" & x).Value range_shape.let_sheet_name = ThisWorkbook.Sheets("SRR Helper").Range("E" & x).Value all_data.Add range_shape End If Next x '******************************************************************************************************************* '******************************************************************************************************************* 'Iterate through collections to push Master File to PP presenation Dim iterator As New WSOrgDisplayAttributes Dim iterator2 As New WSOrgDisplayAttributes Set mySlide = myPresentation.Slides.Add(1, 1) 'Always create at least one slide myPresentation.Designs(1).SlideMaster.CustomLayouts (GetLayoutIndexFromName("SRRLayout", myPresentation.Designs(1))) myPresentation.PageSetup.SlideSize = ppSlideSizeOnScreen 'Set slide orientation and size Dim sheet_counter As Integer sheet_counter = 1 Dim updateslide As Boolean Dim temp As Double temp = (SQPOSITION) * PXLtoINCH For i = 1 To all_data.Count 'Set Worksheet Set iterator = all_data(i) Set iterator2 = Nothing If all_data.Count = 1 Then updateslide = False 'only one sheet so no need for new slide, they are equal Else If i = all_data.Count Then ' last element can't be compared with the next, but can be compared to previous Set iterator2 = all_data(i - 1) If iterator2.get_sheet_name = iterator.get_sheet_name Then updateslide = False Else updateslide = True sheet_counter = sheet_counter + 1 End If Else Set iterator2 = all_data(i + 1) If iterator2.get_sheet_name = iterator.get_sheet_name Then updateslide = False Else updateslide = True sheet_counter = sheet_counter + 1 End If End If End If Set Ws = Workbooks("WS Asset Availability Master Data Spreadsheet.xlsx").Sheets(iterator.get_sheet_name) 'Copy Range from Excel Set rg = Ws.Range(iterator.get_shape_range) 'Set myShape = mySlide.Shapes(mySlide.Shapes.Count) Application.Wait (Now + TimeValue("00:00:1")) 'Copy Excel Range rg.Copy 'Paste to PowerPoint and position mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile Set myShape = mySlide.Shapes(mySlide.Shapes.Count) 'Control the latest shape to be pasted 'Set position: myShape.LockAspectRatio = msoTrue myShape.Height = 0.62 * PXLtoINCH myShape.Width = 9.74 * PXLtoINCH myShape.Left = 0.14 * PXLtoINCH myShape.Top = temp temp = myShape.Top + myShape.Height If updateslide = True Then temp = (SQPOSITION) * PXLtoINCH ' reset temp back to starting position. End If 'Add a slide to the Presentation - only if new sheetname If updateslide = True Then Set mySlide = myPresentation.Slides.Add(sheet_counter, 2) '11 = ppLayoutTitleOnly updateslide = False temp = (SQPOSITION) * PXLtoINCH End If Next i '******************************************************************************************************************* '******************************************************************************************************************* 'Make PowerPoint Visible and Active PowerPointApp.Visible = True PowerPointApp.Activate 'Clear The Clipboard Application.CutCopyMode = False '******************************************************************************************************************* '******************************************************************************************************************* Else MsgBox ("File Does not Exist in local directory - WS Asset Availability Master Data Spreadsheet.xlsx") End If End Sub Function IsFile(ByVal fName As String) As Boolean 'Returns TRUE if the provided name points to an existing file. 'Returns FALSE if not existing, or if it's a folder On Error Resume Next IsFile = ((GetAttr(fName) And vbDirectory) <> vbDirectory) End Function Function CheckFileIsOpen(chkSumfile As String) As Boolean On Error Resume Next CheckFileIsOpen = (Workbooks(chkSumfile).Name = chkSumfile) On Error GoTo 0 End Function Function GetLayoutIndexFromName(sLayoutName As String, oDes As Design) As Long Dim x As Long For x = 1 To oDes.SlideMaster.CustomLayouts.Count If oDes.SlideMaster.CustomLayouts(x).Name = sLayoutName Then GetLayoutIndexFromName = x Exit Function End If Next End Function