我一直在努力使用Excel创建PowerPoint幻灯片，使用.potx文件作为powerpoint模板。
我遇到的问题是我无法弄清楚如何复制slidemaster以便我可以使用自定义布局。
我想创建一个使用.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