PDA

View Full Version : Replacing text in various shape types


questiontoas
09-01-2014, 11:20 PM
Hi,

I am trying to replace a CURRENT TEXT with a new TEXT in various shape types in the slides, titlemaster and slidemaster of a number of open presentations. Unfortunately some shapes are not picked up. The reason could be

a) the master area contains yet another type (other than titlemaster and slidemaster)
b) I have not include the right shape type
c) other reasons I cannot think off.

Below is the script:

Sub Replace_Current_Text()

Dim sld As Slide
Dim grpItem As Shape
Dim shp As Shape
Dim ppt As Presentation

For Each ppt In Application.Presentations 'Loop through all open Presentations
If Not ppt Is Presentations("macro.pptm") Then 'Skip the Presentation that contains this macro
For Each sld In ppt.Slides 'Search all slide
For Each shp In sld.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Current Text", "Next Text")
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "CURRENT TEXT", "Next Text")
End If
If shp.Type = msoTextBox Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Current Text", "Next Text")
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "CURRENT TEXT", "Next Text")
End If
If shp.Type = msoAutoShape Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Current Text", "Next Text")
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "CURRENT TEXT", "Next Text")
End If
End If
Next
Next

For Each shp In ppt.TitleMaster.Shapes 'Search TitleMaster
If shp.TextFrame.HasText Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Current Text", "Next Text")
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "CURRENT TEXT", "Next Text")
End If
If shp.Type = msoTextBox Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Current Text", "Next Text")
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "CURRENT TEXT", "Next Text")
End If
If shp.Type = msoAutoShape Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Current Text", "Next Text")
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "CURRENT TEXT", "Next Text")
End If
Next

For Each shp In ppt.SlideMaster.Shapes 'Search SlideMaster
If shp.TextFrame.HasText Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Current Text", "Next Text")
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "CURRENT TEXT", "Next Text")
End If
If shp.Type = msoTextBox Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Current Text", "Next Text")
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "CURRENT TEXT", "Next Text")
End If
If shp.Type = msoAutoShape Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Current Text", "Next Text")
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "PROPRIETARY CURRENT TEXT", "Next Text")
End If

Next
End If
Next ppt


End Sub

Your help is appreciate for

a) Identifying any error in the script
b) advise how I could potentially identify the shape type in the SlideMaster / TitleMaster to check if I missed the right one
c) any other help.

Thanks a lot.
John Wilson
09-02-2014, 02:22 AM
You need to first say which version. Using TitleMaster is really only appropriate for pre 2007 versions.

Also are you trying to replace ALL of the text in shapes with the new text or just the chosen words.

For example

If the old text was "This is my OLD text"

Are you looking for "It is now THIS" OR "This is my NEW CHOSEN text"
questiontoas
09-02-2014, 02:54 AM
Hi John,

thanks for replying. I use PPT 2010. I have also discovered that 2010 works with design. Therefore, I changed the code but there still seems to be bug somewhere. See below

The NEW TEXT should replace only CURRENT TEXT and nothing else.

Sub Replace_Restricted_Distribution()

Dim sld As Slide
Dim grpItem As Shape
Dim shp As Shape
Dim ppt As Presentation

For Each ppt In Application.Presentations 'Loop through all open Presentations
If Not ppt Is Presentations("macro.pptm") Then 'Skip the Presentation that contains this macro
For Each sld In ppt.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Current Text", "NEW TEXT")
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "CURRENT TEXT", "NEW TEXT")
End If
If shp.Type = msoTextBox Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Current Text", "NEW TEXT")
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "CURRENT TEXT", "NEW TEXT")
End If
If shp.Type = msoAutoShape Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Current Text", "NEW TEXT")
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "CURRENT TEXT", "NEW TEXT")
End If
If shp.Type = msoShapeRectangle Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Current Text", "NEW TEXT")
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "CURRENT TEXT", "NEW TEXT")
End If
End If
Next
Next

For x = 1 To ppt.Designs.Count
For Each shp In ppt.Designs(x).SlideMaster.Shapes
If shp.TextFrame.HasText Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Current Text", "NEW TEXT")
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "CURRENT TEXT", "NEW TEXT")
End If
If shp.Type = msoTextBox Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Current Text", "NEW TEXT")
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "CURRENT TEXT", "NEW TEXT")
End If
If shp.Type = msoAutoShape Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Current Text", "NEW TEXT")
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "CURRENT TEXT", "NEW TEXT")
End If
If shp.Type = msoShapeRectangle Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Current Text", "NEW TEXT")
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "CURRENT TEXT", "NEW TEXT")
End If
Next
Next
End If
Next ppt


End Sub
John Wilson
09-02-2014, 03:46 AM
That's probably not it.

A standard 2010 presentation will have one design (If you look at the Slide Master view = ONE LARGE master and several smaller Custom layouts.

Also much of your replace code is not needed you don't need to check the type of shape only if it has a textframe.

Try this:


Sub FixMyText()
Dim shp As Shape
Dim oDes As Design
Dim oMast As Master
Dim oCust As CustomLayout
Dim sld As Slide
Dim opres As Presentation
For Each opres In Application.Presentations
If opres.Name <> "macro.pptm" Then
' in case there are multiple masters
For Each oDes In opres.Designs

'check the master
Set oMast = oDes.SlideMaster
For Each shp In oMast.Shapes
Call changeText(shp)
Next shp

'check the custom layouts
For Each oCust In oMast.CustomLayouts
For Each shp In oCust.Shapes
Call changeText(shp)
Next shp
Next oCust

'check slides
For Each sld In opres.Slides
For Each shp In sld.Shapes
Call changeText(shp)
Next shp
Next sld

Next oDes
End If
Next opres
End Sub


Sub changeText(shp As Shape)
Dim oTR As TextRange
Dim oTEMP As TextRange
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
Set oTR = shp.TextFrame.TextRange
Do
Set oTEMP = oTR.Replace(FindWhat:="Current text", ReplaceWhat:="Next Text")
Loop While Not oTEMP Is Nothing
End If
End If
End Sub

NOTE This will still not check Tables and Smart art.
questiontoas
09-02-2014, 04:22 AM
It worked like a charm! Thank you so much.