I add a small blue triangle to each of my visible presentation slides that dissolves in after all other animations. This is a visual cue when doing a presentation that I am at the last animation on that slide. This keeps me from hitting the remote and advancing to the next slide before I am done with the current slide.
I tried using the following macro:
Sub AddTriangleShape()
Dim osld As slide
Dim oSh As Shape
For Each osld In ActivePresentation.Slides
If osld.SlideShowTransition.Hidden Then
Else
Set oSh = osld.Shapes.AddShape(msoShapeRightTriangle, 947, 529, 6, 6)
With oSh
.Line.ForeColor.RGB = RGB(0, 0, 255)
.Fill.ForeColor.RGB = RGB(0, 0, 255)
.BlackWhiteMode = msoBlackWhiteDontShow
.Flip (msoFlipHorizontal)
.Name = "#END#"
.AnimationSettings.EntryEffect = ppEffectDissolve
.AnimationSettings.AdvanceMode = ppAdvanceOnTime
.AnimationSettings.AdvanceTime = 0
End With
End If
Next osld
End Sub
There are two capabilities that do not seem to be working. The solid blue fill does not appear to be working, and the animation in the animation pane shows that the triangle should be showing up automatically after the last shape animation, but the slide itself in slideshow mode shows the triangle as soon as I change to the slide. I must be doing something really simple the wrong way. Any hints?
As noted above, Steve pointed out that I needed .Fill.Visible before setting the Foreground color. The animation part was a bit more tricky. Doing AnimationSettings on the shape caused all types of problems. I needed to declare an Effect and then set the effect on the osld using the TimeLine.MainSequence.AddEffect for the shape in question, using an effectid that dissolved, with trigger AfterPrevious and an Index of -1 (last). The full code is shown below. This is now working for me.
I first delete any existing #END# triangles then add the new #END# triangles. This allows me to add more animations and re-run the macro to put the triangle animation last.
Sub AddTriangleShape()
Dim osld As slide
Dim oSh As Shape
Dim oEffect As Effect
ReDim ShapesToDelete(0)
Dim ShapeCount
For Each osld In ActivePresentation.Slides
If osld.SlideShowTransition.Hidden Then
Else
For Each oSh In osld.Shapes
If oSh.Name Like "#END#" Then
ShapeCount = ShapeCount + 1
ReDim Preserve ShapesToDelete(0 To ShapeCount)
Set ShapesToDelete(ShapeCount) = oSh
End If
Next oSh
End If
Next osld
For i = 1 To ShapeCount
ShapesToDelete(i).Delete
Next
For Each osld In ActivePresentation.Slides
If osld.SlideShowTransition.Hidden Then
Else
Set oSh = osld.Shapes.AddShape(msoShapeRightTriangle, 947, 529, 6, 6)
With oSh
.Line.ForeColor.RGB = RGB(0, 0, 255)
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(0, 0, 255)
.BlackWhiteMode = msoBlackWhiteDontShow
.Flip (msoFlipHorizontal)
.Name = "#END#"
End With
Set oEffect = osld.TimeLine.MainSequence.AddEffect _
(Shape:=oSh, effectid:=msoAnimEffectDissolve, trigger:=msoAnimTriggerAfterPrevious, Index:=-1)
End If
Next osld
End Sub
Related
Dim oSh As Shape
For i =1 To 5
I gave here For loop to go and find each shape
With oSh
.Fill.Visible = False
.Line.BackColor.RGB = RGB(255, 255, 0)
Set oSh = Nothing
End With
Next i
But seems like does not work properly
End Sub
Change this:
With oSh
.Fill.Visible = False
.Line.BackColor.RGB = RGB(255, 255, 0)
Set oSh = Nothing
End With
To this, assuming that you want to work with the currently selected slide or slides:
Sub ChangeTheShapes()
' Make sure you select one or more
' slides (in the thumbnail pane or slide sorter)
' before running this.
Dim osh As Shape
Dim oSl As Slide
' in case a shape doesn't have a fill
On Error Resume Next
For Each oSl In ActiveWindow.Selection.SlideRange
For Each osh In oSl.Shapes
With osh
.Fill.Visible = False
.Line.BackColor.RGB = RGB(255, 255, 0)
End With
Next ' Shape
Next 'slide
End Sub
You can also delete anything you've done with the variable i since you're not using it for anything.
I am making a PowerPoint Presentation with a lot of math equations.
I would like to ask if there are any way to change the color of those equations automatically.
I found a solution but it is for Word documents there:
https://www.codeproject.com/Tips/1378034/Macro-to-Change-the-Color-of-all-Equations-in-a-Wo
Sub Change_Equation_Color()
'Macro to Change the Font Color of all Equations in a Word Document
Dim Eq As OMath
For Each Eq In ActiveDocument.OMaths
Eq.Range.Select
Selection.Font.ColorIndex = wdDarkBlue 'Choose Color here, e.g. wdBlack
'Selection.Font.TextColor.RGB = RGB(255, 0, 255) 'To use RGB color, uncomment this line and comment the one above
Next
End Sub
This macro unfortunately does not work in PowerPoint. Could you please provide any solutions for this?
Thank you!
Here's the PowerPoint equivalent:
Sub ColorEquation()
Dim oSlide As Slide
Dim oShape As Shape
For Each oSlide In ActivePresentation.Slides
For Each oShape In oSlide.Shapes
If oShape.HasTextFrame Then
If oShape.TextFrame2.HasText Then
If oShape.TextFrame2.TextRange.MathZones.Length > 0 Then
oShape.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 0, 255)
End If
End If
End If
Next oShape
Next oSlide
End Sub
Use Count instead of Length at line 8.
Sub ColorEquation()
Dim oSlide As Slide
Dim oShape As Shape
For Each oSlide In ActivePresentation.Slides
For Each oShape In oSlide.Shapes
If oShape.HasTextFrame Then
If oShape.TextFrame2.HasText Then
If oShape.TextFrame2.TextRange.MathZones.Count > 0 Then
oShape.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 0, 255)
End If
End If
End If
Next oShape
Next oSlide
End Sub
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 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 am using PowerPoint 2010 and I am trying to add animation to a bunch of shapes that will change their color to green,
but all I get is that the color is changing to dark red
Private Sub CommandButton1_Click()
Dim oshp As Shape
Dim oslide As Slide
Set oslide = ActivePresentation.Slides(1)
'Clear all animations
For i = 1 To oslide.TimeLine.MainSequence.Count
oslide.TimeLine.MainSequence.Item(1).Delete
Next
For i = 1 To 4
Set oshp = oslide.Shapes(i)
' Assign an animation to shape
Set oEffect = oslide.TimeLine.MainSequence.AddEffect(Shape:=oshp, effectId:=msoAnimEffectChangeFillColor, trigger:=msoAnimTriggerAfterPrevious)
oEffect.EffectParameters.Color2.RGB = RGB(0, 255, 0)
oEffect.Timing.SmoothEnd = msoTrue
oEffect.Timing.Duration = 0.2
Next
End Sub