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
Related
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.
I have a 100 slide PowerPoint presentation with tons of tables and would like to use VBA code to change the color of the headers on each table. The default color from the template inputs the table with the below format with the header color as RGB (79, 129, 189):
I need to change the header colors to a darker blue RGB (0, 56, 104). See example below:
The have used the below code before to change shape colors in a presentation, so was wondering if there is a similar method for this new task. Thanks in advance for any help.
`Sub ChangeShapeColor()
Dim shp As Shape
Dim sld As Slide
For Each shp In ActivePresentation.Slides
' Look at each shape on each slide:
For Each shp In sld.Shapes
If shp.Fill.ForeColor.RGB = RGB(79, 129, 189) Then
shp.Fill.ForeColor.RGB = RGB(0, 56, 104)
End If
Next shp
Next sld
End Sub`
This will change the color of the first row of each table in the presentation to red. You can adapt it to the color you want and add the If/Then if you only want to change tables whose header is a specific color.
Sub RecolorTableHeader()
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.HasTable Then
With oSh.Table
For x = 1 To .Columns.Count
.Cell(1, x).Shape.Fill.ForeColor.RGB = RGB(255, 0, 0)
Next
End With
End If
Next
Next
End Sub
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
I have a powerpoint presentation with subtitles in white and yellow text in 1 textbox per slide (white is up, yellow follows). I would like to replace white text with a white dot ("."). Do I need to make a variable and make it count white characters and delete from front?
This is my script so far:
Sub RemoveWhiteText()
Dim oSl As Slide
Dim oSh As Shape
With ActivePresentation
For Each oSl In .Slides
For Each oSh In oSl.Shapes
With oSh
If .HasTextFrame Then
If .TextFrame.HasText Then
If TextRange.Font.Color = vbWhite Then
oSh.TextFrame.Text
End If
End If
End If
End With
Next
Next
End With
End Sub
Please, read my comment to the question. I suggested there to loop through the collection of chars till the color of font is white.
Try this:
Sub RemoveWhiteText()
Dim oSl As Slide, oSh As Shape, oTr As TextRange, i As Long
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
Set oTr = oSh.TextFrame.TextRange
i = 1
Do While oTr.Characters(1, i).Font.Color = vbWhite
i = i + 1
Loop
'MsgBox oTr.Characters(1, i - 1).Text
If i > 1 Then oTr.Characters(1, i - 1).Text = "."
Set oTr = Nothing
End If
End If
Next
Next
End Sub
Each text block of distinct formatting is a Run. In your case, the first run has font color white. You can use that info to run a loop as follows:
Sub StripLeadingWhiteText()
Dim sld As Slide
Dim shp As Shape
Dim rn As TextRange2
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
If shp.TextFrame2.HasText Then
Set rn = shp.TextFrame2.TextRange.Runs(1)
If rn.Font.Fill.ForeColor.RGB = vbWhite Then
rn.Text = "."
End If
End If
End If
Next
Next
End Sub`
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