I have a VBA script that finds a word and replaces it, within a PowerPoint slide. It searches each text box on the slide for the words. One text box does not have the words in it, but has some text in bold. For reason when I run the script, it turns all text in that box bold.
Is there a line of code that I can input that can avoid this?
Sub ReplaceText()
Dim sld As Slide
Set sld = ActivePresentation.Slides(6)
Dim shp As Shape
For Each shp In sld.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Text1", ", NewText")
End If
If shp.TextFrame.HasText Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Text2", "New Text, 2017")
End If
If shp.TextFrame.HasText Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Text3", "New Text")
End If
End If
Next shp
End Sub
Related
I have a powerpoint slide with about 3000 slides. On each slide I have a one picture and a text box. In powerpoint the picture has a specific name attached to it in the selection pane while the text box is named "TextBox 3". Each text box contains the text "2013-09-27 16.27.54". My job is to go through each text box and replace that text with name of the picture in the selection pane. I have written the following code to do this however I am having trouble setting the name of the picture as a string. When I run this code I get "Compile error: Invalid qualifier" on line 10, and Name is highlighted in line 10
How do I get rid of this error? I am assuming it is because the name of the object is not being recognized as a string.
My code is as follows:
Sub Hello()
For Each sld In Application.ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
Set txtRng = shp.TextFrame.TextRange
Set foundText = txtRng.Find(FindWhat:="2013-09-27 16.27.54")
Do While Not (foundText Is Nothing)
With foundText
.Replace(FindWhat:=foundText, _
Replacewhat:=Application.ActivePresentation.Slides(i).Shapes(1).Name.TextRange.TextFrame, WholeWords:=True) = True
End With
Loop
End If
End If
Next
Next
End Sub
Find and Replace is unnecessarily complex. Find the picture, get its name, find the text box, replace the text:
Sub Hello()
Dim sld As Slide
Dim shp As Shape
Dim PicName As String
For Each sld In Application.ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoPicture Then
PicName = shp.Name
End If
Next
For Each shp In sld.Shapes
If shp.HasTextFrame Then
shp.TextFrame.TextRange.Text = PicName
End If
Next
Next
End Sub
I would like to select "Rectangle 132" in each slide, copy the content into the "outline menu" as a title for the slide using VBA.
Ultimately it would be nice to locate the "title" rubric above the actual slide, so it is not displayed on the slide.
Sub LoopThroughSlides()
'PURPOSE: Show how to loop through all slides in the active presentation
Dim sld As Slide
'Loop Through Each Slide in ActivePresentation
For Each sld In ActivePresentation.Slides
'Do something...(ie add a transition to slides)
Function getShapeByName(shapeName As String, Slide As Integer)
Set getShapeByName = ActivePresentation.Slides(Slide).Shapes(shapeName)
End Function
Dim myshape As Shape
myshape = getShapeByName("Rectangle 132", 1)
Next sld
End Function
End Sub
••••ˇˇˇˇ
I've found this but unsure how to apply it:
With ActivePresentation.Slides(1)
If .Layout <> ppLayoutBlank Then
With .Shapes
If Not .HasTitle Then
.AddTitle.TextFrame.TextRange.Text = "Restored title"
End If
End With
End If
End With
Sorry, but titles don't work that way. The Title placeholder has a special status in the program that can't be transferred to other shapes. If you copy the text from Rectangle 132 and paste it to the Title placeholder, it will work as expected.
As an illustration of the special nature of the placeholder, I created a slide using the Blank layout, which has no Title. I opened Outline View, then typed text beside the slide thumbnail. This text is automatically considered the slide title and PowerPoint creates a Title placeholder on the blank slide, even though it didn't previously have one.
When you change your question, please consider starting a new thread, rather than tacking it on to the previous one. Give this VBA a try:
Sub SetTitle()
Dim sld As Slide, oShape As Shape, TitleText As String, TitlePHName As String
For Each sld In ActivePresentation.Slides
For Each oShape In sld.Shapes
If oShape.Name = "Rectangle 132" Then
If oShape.HasTextFrame Then
If oShape.TextFrame2.HasText Then
TitleText = oShape.TextFrame2.TextRange.Text
End If
End If
End If
If Left(oShape.Name, 5) = "Title" Then
TitlePHName = oShape.Name
End If
Next oShape
If sld.Layout <> ppLayoutBlank Then
If sld.Shapes.HasTitle Then
sld.Shapes(TitlePHName).TextFrame2.TextRange.Text = TitleText
Else
sld.Shapes.AddTitle.TextFrame2.TextRange.Text = TitleText
End If
End If
TitlePHName = ""
TitleText = ""
Next sld
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
I saw this post but I couldn't modify my VBA script for PPT presentation. Almost each slide has text in textbox. However, at the end of some textboxes there are multiple line breaks at the end (Enter hits), about 1-3 in some places. I would like to have a macro to delete those uneccessary line breaks. Tell me what I'm doing wrong here (2 scripts):
Sub RemoveSpaces(osh As Shape)
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 Right$(osh.TextFrame.TextRange.Characters(osh.TextFrame.TextRange.Length, 2)) = vbCrLf Then
osh.TextFrame.TextRange.Text = Left$(osh.TextFrame.TextRange.Text, Len(osh.TextFrame.TextRange.Text) - 2)
End If
End If
End If
End With
Next
Next
End With
End Sub
and
Sub RemoveSpaces()
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 osh.TextFrame.TextRange.Characters(osh.TextFrame.TextRange.Length - 2, 2).Text = vbCrLf Then
osh.TextFrame.TextRange.Characters(osh.TextFrame.TextRange.Length - 2, 2).Delete
End If
End If
End If
End With
Next
Next
End With
End Sub
Powerpoint's a bit weird this way; line and paragraph endings may vary depending on the version of PPT you have and on whether the shape is a title placeholder or some other type of shape.
I've got a page on the PowerPoint FAQ I maintain that explains in more detail:
Paragraph endings and line breaks
http://www.pptfaq.com/FAQ00992_Paragraph_endings_and_line_breaks.htm
It is so frustrating that PPT VBA sometimes fails to find a Line/Paragraph break in a text box. TextRange.Text or TextRange.Runs or even TextRange.Charaters doesn't help us find those breaks which are control characters for special purpose.
In this case, 'TextRange.Find' is a useful workaround to find something hidden.
If you want to find and delete breaks in a text box, first find any Chr(13) at the last character in it and then delete the found textrange until not found. The code goes like this:
Sub RemoveBreaks()
Dim oSl As Slide
Dim osh As Shape
Dim tr As TextRange
With ActivePresentation
For Each oSl In ActiveWindow.Selection.SlideRange '.Slides
For Each osh In oSl.Shapes
With osh
If .HasTextFrame Then
If .TextFrame.HasText Then
With .TextFrame.TextRange
Do
Set tr = Nothing
Set tr = .Find(Chr(13), .Length - 1, 1)
If Not tr Is Nothing Then
Debug.Print "Found <BR> in " & osh.Name & _
" on Slide #" & oSl.SlideIndex
tr.Delete
End If
Loop While Not tr Is Nothing
End With
End If
End If
End With
Next
Next
End With
End Sub
When I press enter in PowerPoint, it apparently adds a Vertical Tab which is ASCII code of 11. Try the following:
Sub RemoveSpaces()
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
Do While osh.TextFrame.TextRange.Characters(osh.TextFrame.TextRange.Length - 1, 1).Text = Chr(11)
osh.TextFrame.TextRange.Characters(osh.TextFrame.TextRange.Length - 1, 1).Delete
Loop
End If
End If
End With
Next
Next
End With
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`