PowerPoint loop for specific slide numbers - vba

I have number of slide sets with Excel charts that need to be formatted to be better displayed in PPT (increase font size).
I figured out the code below but can't a way to insert loop so this code is only applied to slides 36 to 45.
I've tried the following code below but doesn't work, I think it's because it references ActivePresentation whilst my formatting code references ActiveWindow but I don't have enought PPT VBA knowledge to fix that.
Dim oPresentation As Presentation
Set oPresentation = ActivePresentation
Dim oSlide As Slide
Dim oSlides As SlideRange
Dim oShape As Shape
Dim slideNumber As Integer
For slideNumber = 36 To 45
>>>REST OF MY CODE INSERTED HERE<<<
Next slideNumber
Sub FormatChartPPT()
'PURPOSE: Increase font size of chart data labels, legend, axes values and categories
Dim ocht As Chart
Dim i As Integer
Dim shp As Shape
'Auto select chart
For Each shp In ActiveWindow.Selection.SlideRange.Shapes
With shp
If .HasChart Then .Select
End With
Next shp
'Apply to selected chart
Set ocht = ActiveWindow.Selection.ShapeRange(1).Chart
'Format data labels
For i = 1 To ocht.SeriesCollection.Count
If ocht.SeriesCollection(i).HasDataLabels Then
With ocht.SeriesCollection(i).DataLabels.Font
.Size = 14
End With
End If
Next i
'Format legend
If ocht.HasLegend Then
With ocht.Legend.Font
.Size = 14
End With
End If
'Format axis values
With ocht.Axes(xlValue).TickLabels.Font
.Size = 14
End With
'Format axis category
With ocht.Axes(xlCategory).TickLabels.Font
.Size = 14
End With
End Sub

You should create a new method that takes a slide and formats the shapes on it as desired. Say we define it as Sub FormatShapes(sld As Slide) (see code later). This method should then be called in your main loop, e.g.:
For SlideNumber = 36 To 45
FormatShapes ActivePresentation.Slides(SlideNumber)
Next SlideNumber
FormatShapes could look like this:
Sub FormatShapes(sld As Slide)
Dim ocht As Chart
Dim shp As Shape
For Each shp In sld.Shapes
If shp.HasChart Then
Set ocht = shp.Chart
... Do shape chart formatting using ocht ...
End If
Next shp
End Sub

Related

"Error -2147188160 (80048240) Shapes (unknown member): Invalid request." when trying to convert objects to images in PowerPoint

I'm a new stackoverflow user so I'm not sure if I'm doing this right, but I'm trying to post a question on a previously given solution by Steve Rindsberg. I don't have enough reputation to comment, and there doesn't appear to be a way to message another user directly, so I'm posting a new question here.
I can't seem to get the code below to work. I'm using PowerPoint O365 Version 1901 and I have two type of shapes I'm trying to convert, msoChart and msoLinkedOLEObject (some Excel worksheets). I originally changed ppPasteEnhancedMetafile to ppPastePNG because I want PNG's, but it fails with either.
Here is the code:
Sub ConvertAllShapesToPic()
Dim oSl As Slide
Dim oSh As Shape
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
' modify the following depending on what you want to
' convert
Select Case oSh.Type
Case msoChart, msoEmbeddedOLEObject, msoLinkedOLEObject
ConvertShapeToPic oSh
Case msoPlaceholder
If oSh.PlaceholderFormat.ContainedType = msoEmbeddedOLEObject _
Or oSh.PlaceholderFormat.ContainedType = msoLinkedOLEObject _
Or oSh.PlaceholderFormat.ContainedType = msoChart _
Then
ConvertShapeToPic oSh
End If
Case Else
End Select
Next
Next
End Sub
Sub ConvertShapeToPic(ByRef oSh As Shape)
Dim oNewSh As Shape
Dim oSl As Slide
Set oSl = oSh.Parent
oSh.Copy
Set oNewSh = oSl.Shapes.PasteSpecial(ppPastePNG)(1)
With oNewSh
.Left = oSh.Left
.Top = oSh.Top
Do
.ZOrder (msoSendBackward)
Loop Until .ZOrderPosition < oSh.ZOrderPosition
End With
oSh.Delete
End Sub
I noticed if I run ConvertAllShapesToPic from an link/action in Slide Show mode, it doesn't complete and fails silently. If I add a Command Button (ActiveX control) and run it from there I get the following:
Run-time error '-2147188160 (80048240)':
Shapes (unknown member): Invalid request. The specified data type is unavailable.
It's failing on Set oNewSh = sld.Shapes.PasteSpecial(ppPastePNG)(1). After the error, if I go back to the slide and Ctrl-V I get the image, so I know it's working up to that point.
I've tried various solutions I found online for this such as adding DoEvents or ActiveWindow.Panes(1).Activate after the copy, but it doesn't seem to make a difference. Any suggestions?
Thanks
I found some other code to convert the charts and then I break links on the worksheets which automatically turns them in to images.
One thing I figured out was you must be out of slide show mode to break msoLinkedOLEObject links. I'm not 100% sure why... but this is the code that works for me:
Sub DoStuff()
Call LinkedGraphsToPictures
ActivePresentation.SlideShowWindow.View.Exit
Call BreakAllLinks
End Sub
Sub LinkedGraphsToPictures()
Dim shp As Shape
Dim sld As Slide
Dim pic As Shape
Dim shp_left As Double
Dim shp_top As Double
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoChart Then
'Retrieve current positioning
shp_left = shp.Left
shp_top = shp.Top
'Copy/Paste as Picture
shp.Copy
DoEvents
sld.Shapes.PasteSpecial DataType:=ppPastePNG
Set pic = sld.Shapes(sld.Shapes.Count)
'Delete Linked Shape
shp.Delete
'Reposition newly pasted picture
pic.Left = shp_left
pic.Top = shp_top
End If
Next shp
Next sld
End Sub
Sub BreakAllLinks()
Dim shp As Shape
Dim sld As Slide
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoLinkedOLEObject Then
shp.LinkFormat.BreakLink
End If
Next shp
Next sld
End Sub

Loop through selected slides and delete namned shape

I am trying to create a "sticker" macro for PowerPoint. In short terms I have a button that marks selected slides with a shape that says "Done". This macro is working. However, I also need a macro that deletes the done-sticker on selected slides. What I have right now manages to delete the shape if only one slide is selected. I am very new to VBA in PowerPoint.
Add sticker macro (that works):
Sub StickerDone()
Dim StickerText As String
Dim sld As Slide
StickerText = "Done"
Dim shp As Shape
For Each sld In ActiveWindow.Selection.SlideRange
'Create shape with Specified Dimensions and Slide Position
Set shp = sld.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=0 * 28.3464567, Top:=0 * 28.3464567, Width:=80, Height:=26.6)
'FORMAT SHAPE
'Shape Name
shp.Name = "StickerDone"
'No Shape Border
shp.Line.Visible = msoFalse
'Shape Fill Color
shp.Fill.ForeColor.RGB = RGB(56, 87, 35)
'Shape Text Color
shp.TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255)
'Text inside Shape
shp.TextFrame.TextRange.Characters.Text = StickerText
'Center Align Text
shp.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignCenter
'Vertically Align Text to Middle
shp.TextFrame2.VerticalAnchor = msoAnchorMiddle
'Adjust Font Size
shp.TextFrame2.TextRange.Font.Size = 14
'Adjust Font Style
shp.TextFrame2.TextRange.Font.Name = "Corbel"
'Rotation
shp.Rotation = 0
Next sld
End Sub
Delete sticker macro (that does not work):
Sub StickerDelete()
Dim shp As Shape
Dim sld As Slide
For Each sld In ActiveWindow.Selection.SlideRange
For Each shp In sld.Shapes
If shp.Name Like "StickerDone" Then
shp.Select
shp.Delete
End If
Next shp
Next sld
End Sub
Deleting objects you are iterating over is generally a bad idea. Add them to an array and delete them after your (inner) loop is done.
Try this:
Sub StickerDelete()
Dim shp As Shape
Dim sld As Slide
ReDim ShapesToDelete(0)
Dim ShapeCount
For Each sld In ActiveWindow.Selection.SlideRange
For Each shp In sld.Shapes
If shp.Name Like "StickerDone" Then
'shp.Select
'shp.Delete
ShapeCount = ShapeCount + 1
ReDim Preserve ShapesToDelete(0 To ShapeCount)
Set ShapesToDelete(ShapeCount) = shp
End If
Next shp
Next sld
For i = 1 To ShapeCount
ShapesToDelete(i).Delete
Next
End Sub

Loop Through Charts on Selected (or Range of) Powerpoint Slides

I am currently using this code to update all links in my powerpoint presentation:
Sub UpdateLinks()
Dim ExcelFile
Dim exl As Object
Set exl = CreateObject("Excel.Application")
ExcelFile = "C:\Users\J\Documents\Reporting\Governance Physical Charts.xlsm"
Dim i As Integer
Dim k As Integer
'Go through every slide
For i = 1 To ActivePresentation.Slides.Count
With ActivePresentation.Slides(i)
'Go through every shape on every slide
For k = 1 To .Shapes.Count
On Error Resume Next
'Set the source to be the same as teh file chosen in the opening dialog box
.Shapes(k).LinkFormat.SourceFullName = ExcelFile
If .Shapes(k).LinkFormat.SourceFullName = ExcelFile Then
'If the change was successful then also set it to update automatically
.Shapes(k).LinkFormat.AutoUpdate = ppUpdateOptionAutomatic 'other option is ppUpdateOptionManual
End If
Next k
End With
Next i
End Sub
Instead of updating the link of every chart in the presentation, is it possible to have this code loop through only selected slides? Or if it's easier - is it possible to set a range? For example, only update charts on slides 15-30?
Thank you!
EDIT:
Resolution provided in comments - here is my revised code
Sub UpdateLinks()
Dim ExcelFile
Dim exl As Object
Set exl = CreateObject("Excel.Application")
Dim sld As Slide
ExcelFile = "C:\Users\J\Documents\Reporting\Governance Physical Charts.xlsm"
Dim i As Integer
Dim shp As Shape
For Each sld In ActivePresentation.Slides.Range(Array(11, 12, 13, 14, 15, 16, 17, 18))
For Each shp In sld.Shapes
On Error Resume Next
shp.LinkFormat.SourceFullName = ExcelFile
If shp.LinkFormat.SourceFullName = ExcelFile Then
shp.LinkFormat.AutoUpdate = ppUpdateOptionAutomatic 'other option is ppUpdateOptionManual
End If
Next shp
Next
End Sub
Yes you can compose custom ranges on Slides as well as on Shapes, using an Array as the index parameter. Try this:
Dim sld As Slide
For Each sld In ActivePresentation.Slides.Range(Array(1, 3, 5))
Debug.Print sld.Name
Next
Output:
Slide2
Slide4
Slide6
p.s. I had deleted a slide in the test presentation.
Since you also mentioned processing just selected slides, you can do that like so:
Sub SelectedSlides()
Dim osl As Slide
For Each osl In ActiveWindow.Selection.SlideRange
Debug.Print osl.SlideIndex
Next
End Sub
Note that this will give you the selected slides in REVERSE order of selection. That is, if you control-click slides 2,4,6, this will give you 6,4,2.

VBA Else If statement acting weird

Alright, so for a PHP script, i need all non-image objects to be converted to images (excluding text) from a .pptx file. As i have quite a lot .pptx files, i tought that i might as well use VBA.
For some reason however, my Else If is acting weird.
Sub nieuwemacro()
Dim oSl As Slide
Dim oSh As Shape
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
' MsgBox (oSh.Type)
' modify the following depending on what you want to
' convert
If oSh.Type = 1 Then
ConvertShapeToPic oSh
Else
End If
Next
Next
End Sub
Sub ConvertShapeToPic(ByRef oSh As Shape)
Dim oNewSh As Shape
Dim oSl As Slide
oSh.Fill.ForeColor.RGB = RGB(0, 0, 0)
Set oSl = oSh.Parent
oSh.Copy
Set oNewSh = oSl.Shapes.PasteSpecial(ppPastePNG)(1)
With oNewSh
.Left = oSh.Left
.Top = oSh.Top
Do
.ZOrder (msoSendBackward)
Loop Until .ZOrderPosition = .ZOrderPosition
End With
oSh.Delete
End Sub
The oSh.Fill.ForeColor.RGB = RGB(0, 0, 0) part is just there to see what happens. And this is the result:
Alright.. So everything is converted properly, except for the big pink ball. So i thought i'd try some other Else ifs. My new Else If statement:
If oSh.Type = 1 Then
ConvertShapeToPic oSh
ElseIf oSh.Type = 14 Then
ConvertShapeToPic oSh
Else
End If
Resulting in this:
Notice how the code now doesnt convert the green bar at the top? It does that when i add or remove IfElse parts...
I don't know why it does this, could someone tell me what i'm doing wrong?
try this
Option Explicit
Sub nieuwemacro()
Dim oSl As Slide
Dim oSh As Shape
Dim oShs() As Shape
Dim nShps As Long, iShp As Long
For Each oSl In ActivePresentation.Slides
ReDim oShs(1 To oSl.Shapes.Count) As Shape
For Each oSh In oSl.Shapes
' MsgBox (oSh.Type)
' modify the following depending on what you want to
' convert
If oSh.Type = 1 Then
nShps = nShps + 1
Set oShs(nShps) = oSh
End If
Next
If nShps > 0 Then
For iShp = 1 To nShps
ConvertShapeToPic oShs(iShp)
Next iShp
End If
Next
End Sub
Sub ConvertShapeToPic(ByRef oSh As Shape)
Dim oNewSh As Shape
Dim oSl As Slide
oSh.Fill.ForeColor.RGB = RGB(0, 0, 0)
Set oSl = oSh.Parent
oSh.Copy
Set oNewSh = oSl.Shapes.PasteSpecial(ppPastePNG)(1)
With oNewSh
.Left = oSh.Left
.Top = oSh.Top
Do
.ZOrder (msoSendBackward)
Loop Until .ZOrderPosition = .ZOrderPosition
End With
oSh.Delete
End Sub
You may also want to consider the following refactoring:
Option Explicit
Sub nieuwemacro()
Dim oSl As Slide
Dim oShs() As Shape
For Each oSl In ActivePresentation.Slides
oShs = GetShapes(oSl, msoAutoShape) '<--| gather shapes of given type and...
ConvertShapesToPics oShs '<--| ...convert them
Next
End Sub
Function GetShapes(oSl As Slide, shType As MsoShapeType) As Shape()
Dim oSh As Shape
Dim nShps As Long
With oSl.Shapes '<--| reference passed slide Shapes collection
ReDim oShs(1 To .Count) As Shape '<--| resize shapes array to referenced slide shapes number (i.e. to maximum possible)
For Each oSh In .Range '<--| loop through referenced slide shapes
If oSh.Type = shType Then '<--| if its type matches the passed one
nShps = nShps + 1 '<--| update gathered shapes counter
Set oShs(nShps) = oSh '<--| fill gathered shapes array
End If
Next
End With
If nShps > 0 Then '<--| if any shape has been gathered
ReDim Preserve oShs(1 To nShps) As Shape '<--| resize array properly ...
GetShapes = oShs '<--| ... and return it
End If
End Function
Sub ConvertShapesToPics(oShs() As Shape)
Dim iShp As Long
If IsArray(oShs) Then '<--| if array has been initialized ...
For iShp = 1 To UBound(oShs) '<--|... then loop through its elements (shapes)
ConvertShapeToPic oShs(iShp) '<--| convert current shape
Next iShp
End If
End Sub
Sub ConvertShapeToPic(ByRef oSh As Shape)
With oSh '<--| reference passed shape
.Fill.ForeColor.RGB = RGB(0, 0, 0) '<--| change its forecolor
.Copy '<--| copy it
With .Parent.Shapes.PasteSpecial(ppPastePNG)(1) '<--| reference pasted shape
.Left = oSh.Left '<--| adjust its Left position
.Top = oSh.Top '<--| adjust its Top position
Do
.ZOrder (msoSendBackward)
Loop Until .ZOrderPosition = .ZOrderPosition
End With
.Delete '<--| delete referenced passed shape
End With
End Sub
Finally, you may want to shorten down "main" sub by two lines more like follwos
Sub nieuwemacro()
Dim oSl As Slide
For Each oSl In ActivePresentation.Slides
ConvertShapesToPics GetShapes(oSl, msoAutoShape) '<--| convert shapes of given type
Next
End Sub
where GetShapes(), ConvertShapesToPics() and ConvertShapeToPic() stays the same.

Changing underlined text font in Powerpoint

I have a large PPT file that I need to format to certain specifications. I need all font to be Arial 14 unless the text is underlined. If the text is underlined I need the font to be 32. Here's my attempt at it so far, I have the Arial 14 part working, but I can't figure out how to select just the underlined text. If anyone has any thoughts it would be appreciated. I also have zero experience with VBA outside of this project, though I am familiar with c++
Sub use()
Dim s As Slide
Dim shp As Shape
For Each s In ActivePresentation.Slides
For Each shp In s.Shapes
If shp.HasTextFrame Then
With shp
.TextFrame.TextRange.Font.Name = "Arial"
.TextFrame.TextRange.Font.Size = 14
If .TextFrame.TextRange.Font.Underline = True Then
.TextFrame.TextRange.Font.Size = 32
End If
With .TextFrame.TextRange
.ParagraphFormat.SpaceBefore = 0
End With
End With
End If
Next shp
Next s
End Sub
Try this
Sub Sample()
Dim oSl As Slide
Dim oSh As Shape
Dim x As Long
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
For x = 1 To Len(oSh.TextFrame.TextRange.Text)
If oSh.TextFrame.TextRange.Characters(x, 1).Font.Underline = True Then
With oSh.TextFrame.TextRange.Characters(x, 1)
.Font.Size = 32
End With
End If
Next
End If
End If
Next
Next
End Sub
Screenshot