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.
Related
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 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
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
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 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`