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!!!
Dmitriy KritskiyAsked:
Who is Participating?
 
Jamie GarrochConnect With a Mentor PowerPoint Consultant & DeveloperCommented:
Please change:

    Dim ppPres As Presentation
    Set ppPres = ppApp.Presentations.Add
    ppPres.PageSetup.SlideSize = ppSlideSizeOnScreen ' value = 1

Open in new window


to this:

    Dim ppPres As  Object ' Presentation in late binding
    Set ppPres = ppApp.Presentations.Add
    ppPres.PageSetup.SlideSize = 1 ' ppSlideSizeOnScreen

Open in new window


Why? Because you are executing this macro from within Excel, you cannot use the object type Presentation unless you add a reference to the VBA project for Microsoft PowerPoint. The project is currently not set to do this and you are therefore using late binding (creating PowerPoint objects on-the-fly).

Can you confirm this now works for you?
0
 
Jamie GarrochPowerPoint Consultant & DeveloperCommented:
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

0
 
Dmitriy KritskiyAuthor Commented:
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

0
Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
Jamie GarrochPowerPoint Consultant & DeveloperCommented:
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!
0
 
Dmitriy KritskiyAuthor Commented:
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.
0
 
Jamie GarrochPowerPoint Consultant & DeveloperCommented:
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
0
 
Dmitriy KritskiyAuthor Commented:
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

0
 
Jamie GarrochPowerPoint Consultant & DeveloperCommented:
You're using late binding so you need to Dim the opPres as Object instead of Presentation.
0
 
Jamie GarrochPowerPoint Consultant & DeveloperCommented:
Sorry, ppPres
0
 
Dmitriy KritskiyAuthor Commented:
I will have to come back to this later. It was not working for me.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.