asked on

Power Point 2013: Force 4:3 aspect ratio in creating new presentation from Excel VBA

Hello,
I have a code that creates Power Point presentation from Excel. An issue came up with an upgrade to PPT 2013 in terms of the slides aspect ratio being 16:9 by default vs. 4:3. I need to keep 4:3 aspect ratio. I tried doing through updating the setting for default PPT template based on the following:
http://www.indezine.com/products/powerpoint/learn/interface/set-standard-ratio-default-ppt2013.html

However, this doesn't help when presentation is being created from Excel VBA. The following is a snippet of my Excel VBA code:

Dim ppApp As Object ' Use late binding
  Dim ppSlide As Object ' Use late binding
  
    
  On Error Resume Next
  
  ' If PowerPoint is open, use the existing instance
  Set ppApp = GetObject(, "PowerPoint.Application")
  On Error GoTo 0
  
  ' If PowerPoint isn't open, create a new instance and a new presentation
  If ppApp Is Nothing Then
    Set ppApp = CreateObject("PowerPoint.Application")
    ppApp.Visible = True
    ppApp.Presentations.Add
  End If

Open in new window

Is there a way to adjust it to check Power Point version, and if it's 2013 force 4:3 aspect ratio?

Thanks!!!

Jamie Garroch (MVP)

The following code with give you the version:

Application.Version

Open in new window

And for Office 2013, each app will return 15.0 so you can detect PowerPoint 2013 and above by this:

If Val(Application.Version) = 15# then

Open in new window

Note : Val is used to guarantee a number for the evaluation for different locales.

Then, to set your presentation to 4:3 you need to set a reference to the presentation object and then set it's aspect ratio by replacing your penultimate line with this:

Dim ppPes as Presentation ' When in PowerPoint or early binding via project reference
Set ppPres = ppApp.Presentations.Add
ppPres.PageSetup.SlideSize = ppSlideSizeOnScreen ' value = 1

Open in new window

Putting all together:

  Dim ppApp As Object ' Use late binding
  Dim ppSlide As Object ' Use late binding
  Dim ppPres as Object ' Presentation. Use late binding
    
  On Error Resume Next
  
  ' If PowerPoint is open, use the existing instance
  Set ppApp = GetObject(, "PowerPoint.Application")
  On Error GoTo 0
  
  ' If PowerPoint isn't open, create a new instance and a new presentation
  If ppApp Is Nothing Then
    Set ppApp = CreateObject("PowerPoint.Application")
    ppApp.Visible = True
    Set ppPres = ppApp.Presentations.Add
    If Val(Application.Version) = 15# Then ppPres.PageSetup.SlideSize =  1 ' ppSlideSizeOnScreen
  End If

  ' Tidy up object variables
  Set ppApp = Nothing
  Set ppPres = Nothing
  Set ppSlide = Nothing

Open in new window

Dmitriy Kritskiy

ASKER

Hi Jamie, I am using the code you actually helped me before with. I think it needs a bit more editing to make it work with PPT 2013, since the code is calling a custom function:

Option Explicit

Public Enum ppPasteDataType
  ppPasteDefault ' 0
  ppPasteBitmap ' 1
  ppPasteEnhancedMetafile ' 2
  ppPasteMetafilePicture '3
  ppPasteGIF ' 4
  ppPasteJPG ' 5
  ppPastePNG ' 6
  ppPasteText ' 7
  ppPasteHTML ' 8
  ppPasteRTF ' 9
  ppPasteOLEObject ' 10
  ppPasteShape ' 11
  xl_link ' 12 (the way this is handled in the original code is not optimised but I haven't modified this)
End Enum

‘Export hard coded sheet and range selections to a PowerPoint presentation
Public Sub ExportToPresentation()
 
  Application.CutCopyMode = False

  Dim ppApp As Object ' Use late binding
  Dim ppSlide As Object ' Use late binding
  
    
  On Error Resume Next
  
  ' If PowerPoint is open, use the existing instance
  Set ppApp = GetObject(, "PowerPoint.Application")
  On Error GoTo 0
  
  ' If PowerPoint isn't open, create a new instance and a new presentation
  If ppApp Is Nothing Then
    Set ppApp = CreateObject("PowerPoint.Application")
    ppApp.Visible = True
    ppApp.Presentations.Add
  End If
  
  Dim MySheets, MyRanges, i As Long
  
  ' Create pairs of sheet reference and range reference in two arrays as per examples:
  MySheets = Array("Sheet1", "Sheet1") 
  MyRanges = Array("A1:AW39", "A41:AW78") ‘ dummy ranges for testing purposes
  
  With ppApp.ActivePresentation.Slides
    For i = LBound(MySheets) To UBound(MySheets)
      If .Count = 0 Then
        Set ppSlide = .Add(1, 12) 'ppLayoutBlank
      Else
        .Add .Count + 1, 12
        Set ppSlide = .Item(.Count)
      End If
      CopyPasteToPowerPoint ppApp, _
                            ppSlide, _
                            Worksheets(MySheets(i)), _
                            Worksheets(MySheets(i)).Range(MyRanges(i)), _
                            PasteType:=ppPasteEnhancedMetafile, _
                            ConvertToDrawing:=True
    Next
  End With
  
  ' Clean up
  Set ppApp = Nothing: Set ppSlide = Nothing
  
 End Sub

Private Function VPCopyPasteToPowerPoint(ByRef ppApp As Object, _
                             ByRef ppSlide As Object, _
                             ByVal oSheet As Worksheet, _
                             ByRef PasteObject As Object, _
                             Optional ByVal PasteType As ppPasteDataType, _
                             Optional ByVal ConvertToDrawing As Boolean)
  Dim PasteRange      As Boolean
  Dim objChart        As ChartObject
  Dim lngSU           As Long
  Dim oShpRng         As Object ' Shape range pasted to PowerPoint
  Dim SlideW          As Single
  Dim SlideH          As Single
  
  Select Case TypeName(PasteObject)
    Case "Range"
      If Not TypeName(Selection) = "Range" Then Application.GoTo PasteObject.Cells(1)
      PasteRange = True
    Case "Chart": Set objChart = PasteObject.Parent
    Case "ChartObject": Set objChart = PasteObject
    Case Else
      MsgBox PasteObject.Name & " is not a valid object to paste. Macro will exit", vbCritical
      Exit Function
  End Select
  
  With Application
    lngSU = .ScreenUpdating
    .ScreenUpdating = 0
  End With
  
  ppApp.ActiveWindow.View.GotoSlide ppSlide.SlideNumber
  
  On Error GoTo -1: On Error GoTo 0
  DoEvents
  
  If PasteRange Then
    Select Case True
      Case PasteType = ppPasteJPG
        'Paste Range as Picture
        PasteObject.CopyPicture Appearance:=1, Format:=-4147
        Set oShpRng = ppSlide.Shapes.PasteSpecial(ppPasteJPG)
        oShpRng(1).Select msoTrue
      Case PasteType = ppPasteHTML
        '//Paste Range as HTML
        PasteObject.Copy
        Set oShpRng = ppSlide.Shapes.PasteSpecial(ppPasteHTML, link:=1)
        oShpRng(1).Select msoTrue
      Case PasteType = xl_link
        '//Paste Range as Linked
        PasteObject.Copy
        Set oShpRng = ppSlide.Shapes.PasteSpecial(ppPasteDefault, link:=1)
        oShpRng(1).Select msoTrue
      Case PasteType = ppPasteEnhancedMetafile
        ' Paste Range as vector format
        PasteObject.Copy
        Set oShpRng = ppSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile)
        oShpRng(1).Select msoTrue
    End Select
  Else
    If PasteType = xl_link Then
      '//Copy & Paste Chart Linked
      objChart.Chart.ChartArea.Copy
      Set oShpRng = ppSlide.Shapes.PasteSpecial(link:=True)
      oShpRng(1).Select msoTrue
    Else
      '//Copy & Paste Chart Not Linked
      objChart.Chart.CopyPicture Appearance:=1, Size:=1, Format:=2
      Set oShpRng = ppSlide.Shapes.Paste.Select
    End If
  End If
   
  '//Center pasted object in the slide (see header notes)
  SlideH = ppApp.ActivePresentation.PageSetup.SlideHeight
  SlideW = ppApp.ActivePresentation.PageSetup.SlideWidth
  With oShpRng(1)
    .LockAspectRatio = True
    If .Height > SlideH Then .Height = SlideH * 0.95
    If .Width > SlideW * 0.95 Then .Width = SlideW * 0.95 'play..original is If .Width > SlideW * 0.9
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, msoTrue
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, msoTrue
  End With
  
  ' Convert to Microsoft Drawing object by ungrouping the first (and only) Shape in the ShapeRange
  If ConvertToDrawing Then
    oShpRng(1).Ungroup.Select
    ' Uncomment the next line to ungroup the group into it's separate component shapes
    ppApp.ActiveWindow.Selection.ShapeRange.Ungroup
  End If

  With Application
    .CutCopyMode = False
    .ScreenUpdating = lngSU
  End With
  
  ' Clean up
  Set oShpRng = Nothing
End Function

Open in new window

Jamie Garroch (MVP)

What is not working in 2013 Dmitriy? When we tested it, we tested on 2013 and I don't see anything in the custom function that wouldn't work in 2013. The only thing to be aware of for future compatibility is Declare statements that must use PtrSafe when operating on 64 bit Office but this macro isn't using any Windows API declarations.

Hang on, you are calling CopyPasteToPowerPoint in line 55 but the function has been renamed to VPCopyPasteToPowerPoint on line 69!

Dmitriy Kritskiy

ASKER

oh no that's just a minor editing issue, the presentation is being pasted in 16:9 aspect ratio slides, and I need to keep them 4:3.

Jamie Garroch (MVP)

Ah - OK, that's because the default design changed to 16:9 in 2013.

Does this not work?

Dim ppPes as Presentation ' When in PowerPoint or early binding via project reference
Set ppPres = ppApp.Presentations.Add
ppPres.PageSetup.SlideSize = ppSlideSizeOnScreen ' value = 1

Open in new window

Note that ppSlideSizeOnScreen = 1 in the PpSlideSizeType enumeration and sets the slide size for the presentation to 4:3 as per this MSFT article:

https://msdn.microsoft.com/en-us/windows/hardware/microsoft.office.interop.powerpoint.ppslidesizetype

Dmitriy Kritskiy

ASKER

Tried the following edit, and getting an error break in the code.

Public Sub ExportToPresentation()

  
  Application.CutCopyMode = False

  Dim ppApp As Object ' Use late binding
  Dim ppSlide As Object ' Use late binding
  
    
  On Error Resume Next
  
  ' If PowerPoint is open, use the existing instance
  Set ppApp = GetObject(, "PowerPoint.Application")
  On Error GoTo 0
  
  ' If PowerPoint isn't open, create a new instance and a new presentation
  If ppApp Is Nothing Then
    
    Set ppApp = CreateObject("PowerPoint.Application")
    ppApp.Visible = True
    Dim ppPres As Presentation
    Set ppPres = ppApp.Presentations.Add
    ppPres.PageSetup.SlideSize = ppSlideSizeOnScreen ' value = 1
  End If
  
  Dim MySheets, MyRanges, i As Long
  
  ' Create pairs of sheet reference and range reference in two arrays as per examples:
  MySheets = Array("Sheet1", "Sheet1")
  MyRanges = Array("A2:AW39", "A41:AW78")
  
  With ppApp.ActivePresentation.Slides
    For i = LBound(MySheets) To UBound(MySheets)
      If .Count = 0 Then
        Set ppSlide = .Add(1, 12) 'ppLayoutBlank
      Else
        .Add .Count + 1, 12
        Set ppSlide = .Item(.Count)
      End If
      VPCopyPasteToPowerPoint ppApp, _
                            ppSlide, _
                            Worksheets(MySheets(i)), _
                            Worksheets(MySheets(i)).Range(MyRanges(i)), _
                            PasteType:=ppPasteEnhancedMetafile, _
                            ConvertToDrawing:=True
    Next
  End With
  
  ' Clean up
  Set ppApp = Nothing: Set ppSlide = Nothing
  
  
  
  
End Sub

Open in new window

Jamie Garroch (MVP)

You're using late binding so you need to Dim the opPres as Object instead of Presentation.

Jamie Garroch (MVP)

Sorry, ppPres

ASKER CERTIFIED SOLUTION

Jamie Garroch (MVP)

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Dmitriy Kritskiy

ASKER

I will have to come back to this later. It was not working for me.