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
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
I have an issue aligning shapes using VBA on PowerPoint (office 360).
I know I can use .Shapes.Range.Align msoAlignBottom, msoFalse
but I don't understand how to make it work with a specific shape name as I always have an error or nothing is happening.
This is the code in which I would like to implement this action:
Sub FixFitToShape()
Dim oSl As Slide
Dim sn As String
Dim oSh As Shape
sn = InputBox("Enter the name of the shape")
On Error Resume Next
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
If oSh.Name = sn Then
Select Case oSh.PlaceholderFormat.Type
Case 1, 3 'Title
oSh.TextFrame2.AutoSize = msoAutoSizeTextToFitShape ' OR msoAutoSizeNone
Case 2, 7 'Text / Content
oSh.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
oSh.Shapes.Range.Align msoAlignBottom, msoTrue
End Select
End If
Next oSh
Next oSl
End Sub
Thank you very much for your help,
Try this code:
Sub FixFitToShape()
Dim oSl As Slide
Dim sn As String
Dim oSh As Shape
'sn = InputBox("Enter the name of the shape")
sn = "Name1" 'debug
'On Error Resume Next
For Each oSl In ActivePresentation.Slides
For i = 1 To oSl.Shapes.Count
Set oSh = oSl.Shapes(i)
If oSh.Name = sn Then
Select Case oSh.Type 'placeholder or not placeholder?
Case msoPlaceholder
' it's a placeholder! check the placeholder's type
If oSh.PlaceholderFormat.Type = ppPlaceholderTitle _
Or oSh.PlaceholderFormat.Type = ppPlaceholderCenterTitle Then
'do smth with placeholder
oSh.TextFrame2.AutoSize = msoAutoSizeTextToFitShape
End If
Case Else 'it's not a placeholder
oSh.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
oSl.Shapes.Range(i).Align msoAlignBottoms, msoTrue 'align it to bottom of the slide
End Select
End If
Next
Next oSl
End Sub
I also recommend removing the On Error Resume Next statement because it hides errors and you don't get useful information about how the code works.
You have to create a ShapeRange that includes the shapes you want to align. Since you are keying off the name of the shape, the example below shows how a wildcard can be used.
Option Explicit
Sub Test()
LineUpShapes 1, "Rectangle", msoAlignTops
End Sub
Sub LineUpShapes(ByVal SlideNumber As Long, _
ByVal ShapeName As String, _
ByVal alignment As MsoAlignCmd)
Dim sl As Slide
Set sl = ActivePresentation.Slides(SlideNumber)
Dim namedShapes() As Variant
Dim shapeCount As Integer
Dim sh As Shape
For Each sh In sl.Shapes
If sh.Name Like (ShapeName & "*") Then
shapeCount = shapeCount + 1
ReDim Preserve namedShapes(shapeCount) As Variant
namedShapes(shapeCount) = sh.Name
Debug.Print "shape name " & sh.Name
End If
Next sh
Dim shapesToAlign As ShapeRange
Set shapesToAlign = sl.Shapes.Range(namedShapes)
shapesToAlign.Align alignment, msoFalse
End Sub
Thank you so much Алексей!
I have readapted your code and it works perfectly! It is always a placeholder in my case ;)
Sub FixFitToShape()
Dim oSl As Slide
Dim sn As String
Dim oSh As Shape
sn = InputBox("Enter the name of the shape")
For Each oSl In ActivePresentation.Slides
For i = 1 To oSl.Shapes.Count
Set oSh = oSl.Shapes(i)
If oSh.Name = sn Then
Select Case oSh.PlaceholderFormat.Type
Case 1, 3 'Title
oSh.TextFrame2.AutoSize = msoAutoSizeTextToFitShape ' OR msoAutoSizeNone
Case 2, 7 'Text / Content
oSh.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
oSl.Shapes.Range(i).Align msoAlignBottoms, msoTrue 'align it to bottom of the slide
End Select
End If
Next
Next oSl
End Sub
I am trying to create a hyperlink on the newly created shape oSh to the newly created slide oSlide through VBA.
The shape is on a different slide than the newly created slide.
Code to create the shape and the slide.
Private Function GetSectionNumber( _
ByVal sectionName As String, _
Optional ParentPresentation As Presentation = Nothing) As Long
If ParentPresentation Is Nothing Then
Set ParentPresentation = ActivePresentation
End If
GetSectionNumber = -1
With ParentPresentation.SectionProperties
Dim i As Long
For i = 1 To .Count
If .Name(i) = sectionName Then
GetSectionNumber = i
Exit Function
End If
Next i
End With
End Function
Public Function GetLayout( _
LayoutName As String, _
Optional ParentPresentation As Presentation = Nothing) As CustomLayout
If ParentPresentation Is Nothing Then
Set ParentPresentation = ActivePresentation
End If
Dim oLayout As CustomLayout
For Each oLayout In ParentPresentation.SlideMaster.CustomLayouts
If oLayout.Name = LayoutName Then
Set GetLayout = oLayout
Exit For
End If
Next
End Function
Private Sub CommandButton1_Click()
Dim Sld As Slide
Dim Shp As Shape
'ERROR HANDLING
If ActivePresentation.Slides.Count < 5 Then
MsgBox "You do not have any slides in your PowerPoint project."
Exit Sub
End If
Set Sld = Application.ActiveWindow.View.Slide
If Sld.SlideIndex <> 5 Then
MsgBox "You are not on the correct slide."
Exit Sub
End If
Set Sld = Application.ActiveWindow.View.Slide
Call AddCustomSlide
Unload UserForm1
End Sub
Sub AddCustomSlide()
'Create new slide
Dim oSlides As Slides, oSlide As Slide
Dim Shp As Shape
Dim Sld As Slide
Dim SecNum As Integer, SlideCount As Integer, FirstSecSlide As Integer
Set oSlides = ActivePresentation.Slides
Set oSlide = oSlides.AddSlide(oSlides.Count - 2, GetLayout("Processwindow"))
SecNum = GetSectionNumber("Main Process")
With ActivePresentation.SectionProperties
SlideCount = .SlidesCount(SecNum)
FirstSecSlide = .FirstSlide(SecNum)
End With
oSlide.MoveTo toPos:=FirstSecSlide + SlideCount - 1
If oSlide.Shapes.HasTitle = msoTrue Then
oSlide.Shapes.Title.TextFrame.TextRange.Text = TextBox1
End If
'Add SmartArt
'Set Shp = oSlide.Shapes.AddSmartArtApplication.SmartArtLayouts(1)
'Create Flowchart Shape
Dim oSh As Shape
Set oSh = ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeFlowchartPredefinedProcess, 50, 100, 83.52, 41.62)
With oSh
With .TextFrame.TextRange
.Text = TextBox1
With .Font
.Name = "Verdana (Body)"
.Size = 8
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
'.Color.SchemeColor = RGB(255, 255, 255)
End With ' Font
End With ' TextRange
End With ' oSh, the shape itself
End Sub
I'm guessing you want this in the last part that does the font formatting:
Dim URLorLinkLocationText as String
With oSh.TextFrame.TextRange.ActionSettings(ppMouseClick)
.Action = ppActionHyperlink
.Hyperlink.SubAddress = URLorLinkLocationText
End With
I want a macro that loops through all the slides and change the text in a table to black. When I try the code below, I get the error message: Method 'Table' of 'Shape' failed.
This is my code:
Sub TableAllBlack()
Dim lRaw As Integer
Dim lCol As Integer
Dim oTbl As Table
Dim osld As Slide
Dim oShp As Shape
With ActivePresentation
For Each oSl In .Slides
For Each oSh In oSl.Shapes
Set oTbl = oSh.Table
With oTbl
For lRow = 1 To .Rows.Count
For lCol = 1 To .Columns.Count
With .Cell(lRow, lCol).Shape
If .HasTextFrame Then
If .TextFrame.HasText Then
TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
End If
End If
End With
Next
Next
End With
Next
Next
End With
End Sub
Not every shape has a Table associated with it. Just add the statement If oSh.HasTable Then... And it should work
This If statement should be placed to encapsulate all of the Table calls, so place it directly before the Set oTbl = oSh.Table line
I am trying to edit a table in a slide, and I am using this code. Can someone please tell me why it isn't working? If instead of s.Shapes.Table I have s.Shapes.Range for example it works fine.
Sub format()
Dim s As Slide
For Each s In ActivePresentation.Slides
With s.Shapes.Table
.TextFrame.TextRange.Font.Name = "Arial"
.TextFrame.TextRange.Font.Size = 30
End With
Next s
End Sub
Like so instead:
Sub format()
Dim s As Slide
Dim oSh As Shape
Dim oTbl As Table
Dim lRow As Long
Dim lCol As Long
For Each s In ActivePresentation.Slides
' If you choose Debug | Compile, this next line fails
' There's no such property as .Table
' With s.Shapes.Table
For Each oSh In s.Shapes
If oSh.HasTable Then
Set oTbl = oSh.Table
For lRow = 1 To oTbl.Rows.Count
For lCol = 1 To oTbl.Columns.Count
With oTbl.Cell(lRow, lCol).Shape.TextFrame.TextRange
.Font.Name = "Arial"
.Font.Size = 30
End With
Next
Next
End If
Next ' Shape
Next s
End Sub