I need to shift the position of text in all textboxes (1 textbox per slide). The subtitles' first language is in white and there's English in yellow. Now I'd like yellow to be on top, white below. So first I'd like to select white, copy, erase, go to the end of yellow and paste (with line break between white/yellow). Can it be done?
Maybe some change to such script would help?
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
This will move the first run with font color white to the end of the text box.
Try this:
Sub MoveWhiteTextToEnd(oSh As Shape)
With oSh
With oSh.TextFrame.TextRange.Runs(1)
If .Font.Color.RGB = vbWhite Then
.Cut
oSh.TextFrame.TextRange.InsertAfter (vbCrLf)
oSh.TextFrame.TextRange.Characters(oSh.TextFrame.TextRange.Length + 1).Paste
End If
End With
End With
End Sub
Update your code with this call:
If .TextFrame.HasText Then
Call MoveWhiteTextToEnd(oSh)
End If
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 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 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`
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