?
SolvedPrivate

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

Posted on 2015-02-17
10
Medium Priority
?
28 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 6
  • 4
10 Comments
 
LVL 12

Expert Comment

by:Jamie Garroch
ID: 40615446
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
ID: 40616619
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 12

Expert Comment

by:Jamie Garroch
ID: 40616679
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
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

Author Comment

by:Dmitriy Kritskiy
ID: 40616748
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 12

Expert Comment

by:Jamie Garroch
ID: 40616772
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
 

Author Comment

by:Dmitriy Kritskiy
ID: 40616818
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 12

Expert Comment

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

Expert Comment

by:Jamie Garroch
ID: 40617013
Sorry, ppPres
0
 
LVL 12

Accepted Solution

by:
Jamie Garroch earned 1500 total points
ID: 40620672
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
ID: 40668467
I will have to come back to this later. It was not working for me.
0

Featured Post

Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

A lot of things can happen during a presentation, worst of which is “death by PowerPoint.” Here are a few mistakes to avoid to make your slides clean.
There are times when I have encountered the need to decompress a response from a PHP request. This is how it's done, but you must have control of the request and you can set the Accept-Encoding header.
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

752 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