I tried creating VBA to delete shapes with specific color from all slides. But after I run those it delete all the shapes on slide. Does someone perhaps have an idea?
For Each sld In ActivePresentation.Slides
TotalShapes = sld.Shapes.Count
For i = TotalShapes to 1 step -1
sld.Shapes(i).Delete
Next
Next
Slides and shapes are held in a collection so you can use For...Each to step through each item in the collection.
You then need to check the colour of each shape before deleting it.
This will delete red shapes:
Sub Test()
Dim sld As Slide
Dim shp As Shape
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
'Debug.Print shp.Name & ": " & shp.Fill.ForeColor.RGB
If shp.Fill.ForeColor.RGB = RGB(255, 0, 0) Then
shp.Delete
End If
Next shp
Next sld
End Sub
Related
I am trying to copy all true or checked boxes on all slides and paste them onto one slide within my presentation. I can't seem to figure it out. Below is the code that I am using. Any help is appreciated.
`Sub ckbxCopy()
Dim shp As Shape
Dim sld As Slide
Dim i As Integer
On Error Resume Next
For Each sld In ActivePresentation.Slides
For i = 1 To 4
shp = ActivePresentation.Slides("CheckBox" & CStr(i))
If Err.Number = 0 Then ' shape exists
If shp.OLEFormat.Object.Value = True Then
shp.Copy
ActivePresentation.Slides(3).Shapes.Paste
End If
End If
Next i
Next sld
End Sub`
This works for me:
Sub ckbxCopy()
Dim shp As Shape, pres As Presentation
Dim sld As Slide, sldDest As Slide
Dim i As Integer, t As Long
Set pres = ActivePresentation
Set sldDest = pres.Slides(3) 'where shapes are to be pasted
sldDest.Shapes.Range.Delete 'remove existing shapes
t = 20
For Each sld In pres.Slides
If sld.SlideIndex <> sldDest.SlideIndex Then
For i = 1 To 4
Set shp = Nothing
Set shp = SlideShape(sld, "CheckBox" & CStr(i))
If Not shp Is Nothing Then
If shp.OLEFormat.Object.Value = True Then
shp.Copy
pres.Slides(3).Shapes.Paste.Top = t 'paste and position
t = t + 20
End If
End If
Next i
End If
Next sld
End Sub
'Return a named shape from a slide (or Nothing if the shape doesn't exist)
Function SlideShape(sld As Slide, shapeName As String) As Shape
On Error Resume Next
Set SlideShape = sld.Shapes(shapeName)
End Function
Sub RenameShapeNameIfSpecificText()
Dim ppt As Presentation, sld As Slide
Set ppt = ActivePresentation
For Each sld In ppt.Slides
Dim shp As Shape
For Each shp In sld.Shapes
If shp.TextFrame.TextRange = "0x" Then
shp.Name = "Counter"
End If
Next shp
Next sld
End Sub
I have a 20-slide presentation in which 18 slides have a shape with the text 0x. I would like to rename those shapes to "Counter".
The above code causes this error: The Specified Value is out of range
I suppose the error is being caused due to images being present too.
Thank you.
"Use the HasTextFrame property to determine whether a shape contains a text frame before you apply the TextFrame property":
Sub RenameShapeNameIfSpecificText()
Dim ppt As Presentation, sld As Slide, shp As Shape
Set ppt = ActivePresentation
For Each sld In ppt.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.TextRange = "0x" Then
shp.Name = "Counter"
End If
End If
Next shp
Next sld
End Sub
I'm new in power-point VBA and I would like to group all shapes /objects in each power-point slide and flipping it horizontalchanging the font to arial in all presentaion slides
here is the code i reached but it groups each shape as alone and i can't adding the grouping before flipping please advise
Sub DTPMacro()
Dim sld As Slide
Dim shp As Shape
Dim sFontName As String
' Edit this as needed:
sFontName = "Arial"
With ActivePresentation
For Each sld In .Slides
For Each shp In sld.Shapes
shp.Flip msoFlipHorizontal
With shp
If .HasTextFrame Then
If .TextFrame.HasText Then
.TextFrame.TextRange.Font.Name = sFontName
End If
End If
End With
Next
Next
End With
End Sub
Try this instead:
Sub DTPMacro()
Dim sld As Slide
Dim shp As Shape
Dim grpshp As Shape
Dim sFontName As String
' Edit this as needed:
sFontName = "Arial"
With ActivePresentation
For Each sld In .Slides
For Each shp In sld.Shapes
' Don't flip the individual shapes
'shp.Flip msoFlipHorizontal
With shp
If .HasTextFrame Then
If .TextFrame.HasText Then
.TextFrame.TextRange.Font.Name = sFontName
End If
End If
End With
Next
' group and flip the shapes on the slide here
Set grpshp = sld.Shapes.Range.Group
grpshp.Flip msoFlipHorizontal
Next
End With
End Sub
I do presentations with background wipes that are flowchart process shapes with the text "wipey" for yellow wipes and "wipeb" for blue wipes. When working out the animations for training slides, I place the wipes in front with 0.75 transparency. Once the wipe-animation order is correct and the wipes properly placed, I move the wipes behind the text with 0 transparency.
My Wipe_Back macro works fine but my Wipe_Front macro is only getting some of the wipes each time it is called. I have to call it multiple times to get all of the shapes moved forward. the macros are almost identical so I am not sure what I am doing wrong, but I am a VBA newbie-ish!
both macros are shown below and I am also open to recommendations on more elegant practices in the code.
Wipe_Back (seems to work):
Sub Wipe_Back()
Dim sld As slide
Dim shp As Shape
Dim str As String
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoAutoShape Then
If shp.HasTextFrame Then
If shp.TextFrame.TextRange = "wipey" Then
shp.Fill.Transparency = 0
shp.ZOrder msoSendToBack
'shp.Fill.Transparency = 0.75
'shp.ZOrder msoBringToFront
End If
If shp.TextFrame.TextRange = "wipeb" Then
shp.Fill.Transparency = 0
shp.ZOrder msoSendToBack
'shp.Fill.Transparency = 0.75
'shp.ZOrder msoBringToFront
End If
End If
End If
Next shp
Next sld
End Sub
Wipe_Front does not consistently work:
Sub Wipe_Front()
Dim sld As slide
Dim shp As Shape
Dim str As String
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoAutoShape Then
If shp.HasTextFrame Then
If shp.TextFrame.TextRange = "wipey" Then
'shp.Fill.Transparency = 0
'shp.ZOrder msoSendToBack
shp.Fill.Transparency = 0.75
shp.ZOrder msoBringToFront
End If
If shp.TextFrame.TextRange = "wipeb" Then
'shp.Fill.Transparency = 0
'shp.ZOrder msoSendToBack
shp.Fill.Transparency = 0.75
shp.ZOrder msoBringToFront
End If
End If
End If
Next shp
Next sld
End Sub
If you change the order of shapes (as changing the z-order does) or delete them in the midst of a For Each/Next loop, the results won't be what you expect.
If deleting shapes, you can use something like this:
For x = sld.Shapes.Count to 1 Step -1
' delete sld.Shapes(x) if it meets your conditions
Next
If changing the z-order, you may need to collect references to the shapes in an array and step through the array a shape at a time.
Okay, got it! Steve Rindsberg pointed me in the right direction and I corrected the "On Error Resume Next" and now the routines are doing what was expected. Thanks for the help!
Wipe Front():
Sub Wipe_Front()
Dim sld As slide
Dim shp As Shape
Dim str As String
Dim wshps() As Shape, i As Long
ReDim wshps(0 To 1)
i = 0
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoAutoShape Then
If shp.HasTextFrame Then
If shp.TextFrame.TextRange = "wipey" Then
Set wshps(i) = shp
i = i + 1
ReDim Preserve wshps(0 To i) As Shape
End If
If shp.TextFrame.TextRange = "wipeb" Then
Set wshps(i) = shp
i = i + 1
ReDim Preserve wshps(0 To i) As Shape
End If
End If
End If
Next shp
For Each wshp In wshps
On Error Resume Next
wshp.Fill.Transparency = 0.75
wshp.ZOrder msoBringToFront
'wshp.Fill.Transparency = 0
'wshp.ZOrder msoSendToBack
Next wshp
Next sld
End Sub
Wipe_Back():
Sub Wipe_Back_New()
Dim sld As slide
Dim shp As Shape
Dim str As String
Dim wshps() As Shape, i As Long
ReDim wshps(0 To 1)
i = 0
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoAutoShape Then
If shp.HasTextFrame Then
If shp.TextFrame.TextRange = "wipey" Then
Set wshps(i) = shp
i = i + 1
ReDim Preserve wshps(0 To i) As Shape
End If
If shp.TextFrame.TextRange = "wipeb" Then
Set wshps(i) = shp
i = i + 1
ReDim Preserve wshps(0 To i) As Shape
End If
End If
End If
Next shp
For Each wshp In wshps
On Error Resume Next
'wshp.Fill.Transparency = 0.75
'wshp.ZOrder msoBringToFront
wshp.Fill.Transparency = 0
wshp.ZOrder msoSendToBack
Next wshp
Next sld
End Sub
Can anyone help me with the below code? I am trying to use VBA to remove any extra spaces in a PowerPoint presentation.
Sub removeSpaces()
Dim sld As Slide
Dim shp As Shape
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
Do While InStr(shp, " ") > 0
shp.Value = Replace(shp, " ", " ")
shp.Value = Trim(shp.Value)
Next shp
Next sld
End Sub
When I currently run it, it shows an error of "Method or data member not found" and highlights the "shp.Value" part.
a Shape object doesn't have a .Value property. The Instr function may also not evaluate against a Shape object.
https://msdn.microsoft.com/en-us/library/office/ff747227(v=office.14).aspx
Generally, you need to refer to the shape's TextFrame, like:
Dim shpText as String
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
shpText = shp.TextFrame.TextRange.Text 'Get the shape's text
Do While InStr(shpText, " ") > 0
shpText = Trim(Replace(shpText, " ", " "))
Loop
shp.TextFrame.TextRange.Text = shpText 'Put the new text in the shape
Else
shpText = vbNullString
End If
Next shp
Next sld
End Sub