Option Explicit
'https://www.mrexcel.com/forum/excel-questions/1105935-using-macros-make-powerpoint-slides-excel.html
Sub Test_CopyItemToPPT()
CopyItemToPPT Worksheets("Sheet1"), Worksheets("Sheet1").ChartObjects(1), "Chart"
CopyItemToPPT Worksheets("Sheet1"), Range("A1"), "Cell"
CopyItemToPPT Worksheets("Sheet1"), Range("A1:H20"), "Range"
CopyItemToPPT Worksheets("Sheet1"), Selection, TypeName(Selection)
End Sub
Sub CopyItemToPPT(wksFrom As Worksheet, varCopyWhat As Variant, sSlideName As String)
'Will copy wksFrom!Range(sRangeFrom) to the end of the open PPT
' (or create a PPT if none open) with a slide name of sSlideName
'Code modified from:
'http://peltiertech.com/Excel/XL_PPT.html
'Sub ExcelToExistingPowerPoint()
Dim PPApp As Object ' As PowerPoint.Application
Dim PPPres As Object ' As PowerPoint.Presentation
Dim PPSlide As Object ' As PowerPoint.Slide
Dim ppShape As Object
Dim sngHeightScale As Single
Dim sngWidthScale As Single
Dim sngScale As Single
Dim sOutputSheet As String 'Name of sheet that will be copied
Dim sOutputPath As String
Dim sRangeFrom As String
Dim sngHeight As Single
Dim sngWidth As Single
Dim sPPTName As String
'What is being copied? Save its height and width
If TypeName(varCopyWhat) = "Range" Then
'That is OK
sRangeFrom = varCopyWhat.Address
sngHeight = varCopyWhat.Height
sngWidth = varCopyWhat.Width
ElseIf TypeName(varCopyWhat.Parent) = "Chart" Then
'That is OK
Set varCopyWhat = varCopyWhat.Parent
sngHeight = varCopyWhat.Parent.Height
sngWidth = varCopyWhat.Parent.Width
sSlideName = TypeName(varCopyWhat)
ElseIf TypeName(varCopyWhat) = "ChartObject" Then
'That is OK
sngHeight = varCopyWhat.Height
sngWidth = varCopyWhat.Width
Else
MsgBox "The typename for the object to be copied is " & TypeName(varCopyWhat) & "." & vbLf & vbLf & _
"This code is not currently designed to copy it to PPT. Exiting", , "Can't Copy Item"
End
End If
'Set output path
If ThisWorkbook.Path = vbNullString Then
sOutputPath = Environ("userprofile") & "\Documents\"
Else
sOutputPath = ThisWorkbook.Path & "\"
End If
' Reference instance of PowerPoint, using late binding so PPT reference does not have to be added
On Error Resume Next
' Check whether PowerPoint is running
Set PPApp = GetObject(, "PowerPoint.Application")
If PPApp Is Nothing Then
' PowerPoint is not running, create new instance
Set PPApp = CreateObject("PowerPoint.Application")
' For automation to work, PowerPoint must be visible
PPApp.Visible = True
End If
On Error GoTo 0
' Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
'If there is no Presentation in PPApp, create one with YYYYMMDD hhmmss as the presentation name
' and a first sheet containing that name
sPPTName = Format(Now(), "yyyymmdd hhmmss")
If PPApp.Presentations.Count = 0 Then
PPApp.Presentations.Add WithWindow:=msoTrue
If Left(PPApp.Presentations(1).Name, 10) = "Presentati" Then '
PPApp.Presentations(1).Slides.Add PPApp.ActivePresentation.Slides.Count + 1, 11
PPApp.ActiveWindow.Selection.SlideRange.Shapes("Title 1").TextFrame2.TextRange.Text = sPPTName
PPApp.Presentations(1).SaveAs Filename:=sOutputPath & sPPTName
End If
'PPApp.Presentations.Add WithWindow:=msoTrue 'sometimes needed 2nd to get any to show up
End If
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = 1 ' 1 = ppViewSlide
'Position PPT window
Dim sngScreenWidth As Single
Dim sngScreenHeight As Single
Dim sngRibbonHeight1 As Single
Dim sngRibbonHeight2 As Single
With PPApp
.WindowState = 3 'ppWindowMaximized
sngScreenWidth = .Width
sngScreenHeight = .Height
.WindowState = 1 'ppWindowNormal
.Width = sngScreenWidth / 3
.Height = sngScreenHeight / 2
.Left = 2 * .Width
.Top = .Height
'Collapse Ribbon if visible
If .CommandBars("Ribbon").Height > 100 Then _
.CommandBars.ExecuteMso ("MinimizeRibbon")
.ActivePresentation.PageSetup.SlideSize = 2 ' ppSlideSizeLetterPaper
'Fit Presentation in PPT Window
'.ActiveWindow.View.Zoom = 40
PPApp.ActiveWindow.View.Zoomtofit = msoTrue 'Does not work
End With
' Create & Reference new active slide
PPApp.ActivePresentation.Slides.Add PPApp.ActivePresentation.Slides.Count + 1, 11 'ppLayoutTitleOnly = 11 ppLayoutBlank = 12
PPApp.ActiveWindow.View.GotoSlide Index:=PPApp.ActivePresentation.Slides.Count
Set PPSlide = PPPres.Slides _
(PPApp.ActivePresentation.Slides.Count)
' Copy specified range as picture
If TypeName(varCopyWhat) = "Range" Then
wksFrom.Range(sRangeFrom).CopyPicture Appearance:=xlScreen, Format:=xlPicture
Else
varCopyWhat.CopyPicture Appearance:=xlScreen, Format:=xlPicture
End If
' Paste image
PPApp.Visible = True 'Got to be visible to paste to it
'PPSlide.Shapes.Paste.Select 'Used to work !
Set ppShape = PPSlide.Shapes.Paste
'Reset pasted image to original aspect ratio (can get stretched during paste)
PPApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = False
PPApp.ActiveWindow.Selection.ShapeRange.Height = sngHeight
PPApp.ActiveWindow.Selection.ShapeRange.Width = sngWidth
PPApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = True
'Resize & Align pasted image to fit PPT page
sngHeightScale = PPApp.ActiveWindow.Selection.ShapeRange.Height / PPPres.PageSetup.SlideHeight
sngWidthScale = PPApp.ActiveWindow.Selection.ShapeRange.Width / (PPPres.PageSetup.SlideWidth)
If sngWidthScale > 1 Or sngHeightScale > 1 Then
'At least 1 dimension too big scale down, lock ratio
If sngHeightScale > sngWidthScale Then
sngScale = sngHeightScale
Else
sngScale = sngWidthScale
End If
With PPApp.ActiveWindow.Selection.ShapeRange
.ScaleWidth 1 / sngScale, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1 / sngScale, msoFalse, msoScaleFromTopLeft
End With
Else
With PPApp.ActiveWindow.Selection.ShapeRange
' .ScaleWidth 1, msoTrue, msoScaleFromTopLeft
' .ScaleHeight 1, msoTrue, msoScaleFromTopLeft
End With
End If
With PPApp.ActiveWindow.Selection.ShapeRange
.Align msoAlignCenters, True
.Align msoAlignMiddles, True
.IncrementTop 18
End With
With PPApp.ActiveWindow.Selection.SlideRange.Shapes("Title 1")
.TextFrame.WordWrap = msoFalse
.TextFrame2.TextRange.Text = sSlideName
.TextFrame2.TextRange.Font.Size = 14
.TextFrame.AutoSize = 1 'ppAutoSizeShapeToFitText
.Left = 10
.Top = 10
End With
'Stop
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub
