SolvedPrivate

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

Posted on 2015-02-17
10
21 Views
Last Modified: 2016-02-10
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!!!
0
Comment
Question by:Dmitriy Kritskiy
  • 6
  • 4
10 Comments
 
LVL 9

Expert Comment

by:Jamie Garroch
Comment Utility
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
 

Author Comment

by:Dmitriy Kritskiy
Comment Utility
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
 
LVL 9

Expert Comment

by:Jamie Garroch
Comment Utility
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
 

Author Comment

by:Dmitriy Kritskiy
Comment Utility
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
 
LVL 9

Expert Comment

by:Jamie Garroch
Comment Utility
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
6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

 

Author Comment

by:Dmitriy Kritskiy
Comment Utility
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
 
LVL 9

Expert Comment

by:Jamie Garroch
Comment Utility
You're using late binding so you need to Dim the opPres as Object instead of Presentation.
0
 
LVL 9

Expert Comment

by:Jamie Garroch
Comment Utility
Sorry, ppPres
0
 
LVL 9

Accepted Solution

by:
Jamie Garroch earned 500 total points
Comment Utility
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
 

Author Closing Comment

by:Dmitriy Kritskiy
Comment Utility
I will have to come back to this later. It was not working for me.
0

Featured Post

Better Security Awareness With Threat Intelligence

See how one of the leading financial services organizations uses Recorded Future as part of a holistic threat intelligence program to promote security awareness and proactively and efficiently identify threats.

Join & Write a Comment

Introduction This Article briefly covers methods of calculating the NPV and IRR variants in Excel as well as the limitations in calculating and interpreting IRR results. Paraphrasing Richard Shockley, author of my favourite finance reference tex…
Many programs have tried to outwit PowerPoint in terms of technology and skill. These programs, however, still lack several characteristics that PowerPoint has possessed from the start. Here's why PowerPoint replacements won't entirely work for desi…
The viewer will learn how to  create a slide that will launch other presentations in Microsoft PowerPoint. In the finished slide, each item launches a new PowerPoint presentation and when each is finished it automatically comes back to this slide: …
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.

771 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now