Macro update for VBA PPT to fit contents of a slide to a specific predefined workarea - vba

Question

I have a macro for VBA PPT to fit contents of a slide to a specific predefined workarea, now I select the required shapes to be fit into workarea and run this tool slide by slide. can anybody suggest how can I select multiple slides and get all the shapes (except placeholders) in those slides fit to the same work area
Sub FitContents()
Dim shp, grid, ZenSmartGroup, ZenWorkGrid As Shape
Dim SelectShapes As Variant
Dim targetSlides As SlideRange
Dim thisSlide, oSld As Slide
Dim theseShapes As ShapeRange
Set thisSlide = ActivePresentation.Slides(1)
Dim GridTop, GridLeft, GridHeight, GridWidth As Single
If ActiveWindow.Selection.Type = ppSelectionSlides Then
Set targetSlides = ActiveWindow.Selection.SlideRange
End If
For Each oSld In targetSlides
For Each shp In oSld.Shapes
If Not ActivePresentation.Slides(1).Tags("Font Size") = "" Then
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
shp.TextFrame.TextRange.Font.Size = ActivePresentation.Slides(1).Tags("Font Size")
End If
End If
End If
Next
If ActivePresentation.Slides(1).Tags("Grid Height") = "" Then
MsgBox "Please set grid size in Prezent Admin > Settings", vbInformation, "Set Grid Size"
End
End If
GridTop = ActivePresentation.Slides(1).Tags("Grid Top")
GridLeft = ActivePresentation.Slides(1).Tags("Grid Left")
GridHeight = ActivePresentation.Slides(1).Tags("Grid Height")
GridWidth = ActivePresentation.Slides(1).Tags("Grid Width")
oSld.Select
ActiveWindow.ViewType = ppViewSlide
ActiveWindow.Selection.ShapeRange.Group.Select
With ActiveWindow.Selection.ShapeRange(1)
.Top = GridTop
.Left = GridLeft
.LockAspectRatio = frmFitToGrid.chkAspectRatio
.Width = GridWidth
.Height = GridHeight
If frmFitToGrid.optHeight = True Then
.Height = GridHeight
End If
'If .Width > GridWidth Then
If frmFitToGrid.optWidth = True Then
.Width = GridWidth
End If
.Tags.Add "Type", "ZenSmartGroup"
.Name = "ZenSmartGroup"
End With
Set grid = oSld.Shapes.AddShape(msoShapeRectangle, GridLeft, GridTop, GridWidth, GridHeight)
grid.Fill.Visible = msoFalse
grid.Line.Visible = msoTrue
grid.Line.ForeColor.RGB = RGB(0, 255, 0)
grid.Line.Weight = 2.25
'grid.Select
grid.Name = "ZenWorkGrid"
SelectShapes = Array("ZenSmartGroup", "ZenWorkGrid")
'Set theseShapes = thisSlide.Shapes.Range(SelectShapes)
'theseShapes.Align msoAlignMiddles, msoFalse
'theseShapes.Align msoAlignCenters, msoFalse
Set ZenSmartGroup = oSld.Shapes("ZenSmartGroup")
Set ZenWorkGrid = oSld.Shapes("ZenWorkGrid")
'Align Middle (Horizontal Center)
If Not (frmFitToGrid.chkAlignLeft) Then
ZenSmartGroup.Top = ZenWorkGrid.Top + ((ZenWorkGrid.Height - ZenSmartGroup.Height) / 2)
End If
'Align Center (Vertical Center)
If Not (frmFitToGrid.chkAlignTop) Then
ZenSmartGroup.Left = ZenWorkGrid.Left + ((ZenWorkGrid.Width - ZenSmartGroup.Width) / 2)
End If
grid.Delete
'ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, msoFalse
'ActiveWindow.Selection.ShapeRange(1).Delete
'ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, msoTrue
oSld.Shapes.Range.Ungroup
Next
End Sub

Answer 1

NOTE: code below serves as an example, as it cannot be tested given the information in your post. Please adapt it to your situation as needed.
I've included several (hopefully) helpful additions to your code in order to improve readability and maintainability. These include:
Error Checking - make sure the user has provided all the values required for the macro to effectively execute, and...
... declare your variables as close as possible to their first use.
Note the use of targetSlides as the focus object for all the selected slides. This way you avoid to continually reference ActivePresentation.Slides(1). (Note this was an assumption on my part, adjust the code as necessary)
'--- make sure the user has selected at least two slides
Dim targetSlides As SlideRange
If ActiveWindow.Selection.Type = ppSelectionSlides Then
Set targetSlides = ActiveWindow.Selection.SlideRange
Else
MsgBox "Please select two or more slides in the left-hand slide overview panel.", _
vbCritical + vbInformation + vbOKOnly, "Select Slides for Grids"
Exit Sub
End If
'--- make sure the grid values are set
If targetSlides(1).Tags("Grid Height") = vbNullString Then
MsgBox "Please set grid size in Prezent Admin > Settings", _
vbCritical + vbInformation + vbOKOnly, "Set Grid Size"
End
End If
'--- assumes ONLY the first slide in the target slides has the Grid tags
Dim gridTop As Long
Dim gridLeft As Long
Dim gridHeight As Long
Dim gridWidth As Long
Dim fontSize As Double
With targetSlides(1)
gridTop = .Tags("GRID TOP")
gridLeft = .Tags("GRID LEFT")
gridHeight = .Tags("GRID HEIGHT")
gridWidth = .Tags("GRID WIDTH")
fontSize = IIf(.Tags("FONT SIZE") <> vbNullString, .Tags("FONT SIZE"), 0#)
End With
Break code into separate subs or functions to increase the readability of the logic.
It's easy to get lose the overall point of the solution when you have to mentally summarize large blocks of code. In my example, the main logic loop is:
Dim sld As Slide
For Each sld In targetSlides
ResetTextSize fontSize, sld
Dim slideShapes As ShapeRange
Set slideShapes = SelectAllShapes(sld)
CreateShapeGrid sld, slideShapes, _
gridTop, gridLeft, gridHeight, gridWidth
Next
Before looking at the full solution below, look at some of the supporting subs and functions. Most especially, note the function IsPlaceholder which checks a Shape on any slide to see if it's part of the layout (and shouldn't be selected) or not.
Full code module:
Option Explicit
Sub FitContents()
'--- make sure the user has selected at least two slides
Dim targetSlides As SlideRange
If ActiveWindow.Selection.Type = ppSelectionSlides Then
Set targetSlides = ActiveWindow.Selection.SlideRange
Else
MsgBox "Please select two or more slides in the left-hand slide overview panel.", _
vbCritical + vbInformation + vbOKOnly, "Select Slides for Grids"
Exit Sub
End If
'--- make sure the grid values are set
If targetSlides(1).Tags("Grid Height") = vbNullString Then
MsgBox "Please set grid size in Prezent Admin > Settings", _
vbCritical + vbInformation + vbOKOnly, "Set Grid Size"
End
End If
'--- assumes ONLY the first slide in the target slides has the Grid tags
Dim gridTop As Long
Dim gridLeft As Long
Dim gridHeight As Long
Dim gridWidth As Long
Dim fontSize As Double
With targetSlides(1)
gridTop = .Tags("GRID TOP")
gridLeft = .Tags("GRID LEFT")
gridHeight = .Tags("GRID HEIGHT")
gridWidth = .Tags("GRID WIDTH")
fontSize = IIf(.Tags("FONT SIZE") <> vbNullString, .Tags("FONT SIZE"), 0#)
End With
Dim sld As Slide
For Each sld In targetSlides
ResetTextSize fontSize, sld
Dim slideShapes As ShapeRange
Set slideShapes = SelectAllShapes(sld)
CreateShapeGrid sld, slideShapes, _
gridTop, gridLeft, gridHeight, gridWidth
Next
End Sub
Sub ResetTextSize(ByVal fontSize As Double, ByRef sld As Slide)
'--- (re)set the font sizes in all shapes with text, as long
' as it's not a placeholder shape on the current slide
If fontSize > 0 Then
Dim shp As Shape
For Each shp In sld.Shapes
If Not IsPlaceholder(sld, shp) Then
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
shp.TextFrame.TextRange.Font.Size = fontSize
End If
End If
End If
Next
End If
End Sub
Function IsPlaceholder(ByRef sld As Slide, ByRef shp As Shape) As Boolean
With sld.Shapes.Placeholders
IsPlaceholder = False
If .Count > 0 Then
Dim i As Long
For i = 1 To .Count
If .Item(i).Name = shp.Name Then
IsPlaceholder = True
Exit Function
End If
Next i
End If
End With
End Function
Function CollectionToArray(ByRef c As Collection) As Variant()
Dim a() As Variant: ReDim a(0 To c.Count - 1)
Dim i As Integer
For i = 1 To c.Count
a(i - 1) = c.Item(i)
Next
CollectionToArray = a
End Function
Function SelectAllShapes(ByRef sld As Slide) As ShapeRange
'--- creates a Collection of all the non-placeholder shape names, then
' convert the names to an array to create a ShapeRange object
Dim shp As Shape
Dim shps As Collection
Set shps = New Collection
For Each shp In sld.Shapes
If Not IsPlaceholder(sld, shp) Then
shps.Add shp.Name
End If
Next shp
If shps.Count > 0 Then
Dim shpsArray() As Variant
shpsArray = CollectionToArray(shps)
Set SelectAllShapes = sld.Shapes.Range(shpsArray)
Else
Set SelectAllShapes = Nothing
End If
End Function
Sub CreateShapeGrid(ByRef sld As Slide, ByRef slideShapes As ShapeRange, _
ByVal gridTop As Long, ByVal gridLeft As Long, _
ByVal gridHeight As Long, ByVal gridWidth As Long)
'--- position the group of shapes
With slideShapes.Group
.top = gridTop
.left = gridLeft
.LockAspectRatio = frmFitToGrid.chkAspectRatio
.width = gridWidth
.height = gridHeight
If frmFitToGrid.optHeight = True Then
.height = gridHeight
End If
'If .Width > GridWidth Then
If frmFitToGrid.optWidth = True Then
.width = gridWidth
End If
.Tags.Add "Type", "ZenSmartGroup"
.Name = "ZenSmartGroup"
End With
'--- now create a grid over the shapes
Dim grid As Shape
Set grid = sld.Shapes.AddShape(msoShapeRectangle, gridLeft, gridTop, gridWidth, gridHeight)
grid.Fill.Visible = msoFalse
grid.Line.Visible = msoTrue
grid.Line.ForeColor.RGB = RGB(0, 255, 0)
grid.Line.Weight = 2.25
'grid.Select
grid.Name = "ZenWorkGrid"
SelectShapes = Array("ZenSmartGroup", "ZenWorkGrid")
'Set theseShapes = thisSlide.Shapes.Range(SelectShapes)
'theseShapes.Align msoAlignMiddles, msoFalse
'theseShapes.Align msoAlignCenters, msoFalse
Set ZenSmartGroup = sld.Shapes("ZenSmartGroup")
Set ZenWorkGrid = sld.Shapes("ZenWorkGrid")
'Align Middle (Horizontal Center)
' If Not (frmFitToGrid.chkAlignLeft) Then
' ZenSmartGroup.Top = ZenWorkGrid.Top + ((ZenWorkGrid.Height - ZenSmartGroup.Height) / 2)
' End If
'
' 'Align Center (Vertical Center)
' If Not (frmFitToGrid.chkAlignTop) Then
' ZenSmartGroup.Left = ZenWorkGrid.Left + ((ZenWorkGrid.Width - ZenSmartGroup.Width) / 2)
' End If
grid.Delete
'ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, msoFalse
'ActiveWindow.Selection.ShapeRange(1).Delete
'ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, msoTrue
slideShapes.Ungroup
End Sub