J
John Svendsen
Hi All,
In PPT2003 this works like a charm, but in PPT2007 it complains when there
is a table in the presentation (when it calls itself with a table cell, it
seems to not like the "Select Case oShp.Type" - btw, I turned the 'On Error
Resume Next' off).
Is this true with PPT2007 ? If so, any ideas how to fix this (I so much use
this!!!)
TIA, JS
Sub GlobalFindAndReplace_ShyamPillai()
' --------------------------------------------------------------------------------
' Copyright ©1999-2007, Shyam Pillai, All Rights Reserved.
' --------------------------------------------------------------------------------
' You are free to use this code within your own applications, add-ins,
' documents etc but you are expressly forbidden from selling or
' otherwise distributing this source code without prior consent.
' This includes both posting free demo projects made from this
' code as well as reproducing the code in text or html format.
' --------------------------------------------------------------------------------
Dim oPres As Presentation
Dim oSld As Slide
Dim oShp As Shape
Dim FindWhat As String
Dim ReplaceWith As String
Dim Sldnum As Long, Shpnum As Long
Sldnum = 0
FindWhat = "Like"
ReplaceWith = "Not Like"
' For Each oPres In Application.Presentations
' For Each oSld In oPres.Slides
For Each oSld In ActivePresentation.Slides
Sldnum = Sldnum + 1
For Each oShp In oSld.Shapes
ActiveWindow.View.GotoSlide Sldnum
oShp.Select
Call ReplaceText(oShp, FindWhat, ReplaceWith)
Next oShp
Next oSld
' Next oPres
End Sub
Sub ReplaceText(oShp As Object, FindString As String, ReplaceString As
String)
Dim oTxtRng As TextRange
Dim oTmpRng As TextRange
Dim I As Integer
Dim iRows As Integer
Dim iCols As Integer
Dim oShpTmp As Shape
' Always include the 'On error resume next' statememt below when you are
working with text range object.
' I know of at least one PowerPoint bug where it will error out - when
an image has been dragged/pasted
' into a text box. In such a case, both HasTextFrame and HasText
properties will return TRUE but PowerPoint
' will throw an error when you try to retrieve the text.
'*** On Error Resume Next ****
Select Case oShp.Type
Case 19 'msoTable
For iRows = 1 To oShp.Table.Rows.Count
For iCol = 1 To oShp.Table.Rows(iRows).Cells.Count
Set oShpTmp = oShp.Table.Rows(iRows).Cells(iCol).Shape
Call ReplaceText(oShpTmp, FindString, ReplaceString)
Next
Next
Case msoGroup 'Groups may contain shapes with text, so look within it
For I = 1 To oShp.GroupItems.Count
Call ReplaceText(oShp.GroupItems(I), FindString, ReplaceString)
Next I
Case 21 ' msoDiagram
For I = 1 To oShp.Diagram.Nodes.Count
Call ReplaceText(oShp.Diagram.Nodes(I).TextShape, FindString,
ReplaceString)
Next I
Case Else
If oShp.HasTextFrame Then
If oShp.TextFrame.HasText Then
Set oTxtRng = oShp.TextFrame.TextRange
Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _
Replacewhat:=ReplaceString,
WholeWords:=True)
Do While Not oTmpRng Is Nothing
Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _
Replacewhat:=ReplaceString,
_
After:=oTmpRng.Start +
oTmpRng.Length, _
WholeWords:=True)
Loop
End If
End If
End Select
End Sub
In PPT2003 this works like a charm, but in PPT2007 it complains when there
is a table in the presentation (when it calls itself with a table cell, it
seems to not like the "Select Case oShp.Type" - btw, I turned the 'On Error
Resume Next' off).
Is this true with PPT2007 ? If so, any ideas how to fix this (I so much use
this!!!)
TIA, JS
Sub GlobalFindAndReplace_ShyamPillai()
' --------------------------------------------------------------------------------
' Copyright ©1999-2007, Shyam Pillai, All Rights Reserved.
' --------------------------------------------------------------------------------
' You are free to use this code within your own applications, add-ins,
' documents etc but you are expressly forbidden from selling or
' otherwise distributing this source code without prior consent.
' This includes both posting free demo projects made from this
' code as well as reproducing the code in text or html format.
' --------------------------------------------------------------------------------
Dim oPres As Presentation
Dim oSld As Slide
Dim oShp As Shape
Dim FindWhat As String
Dim ReplaceWith As String
Dim Sldnum As Long, Shpnum As Long
Sldnum = 0
FindWhat = "Like"
ReplaceWith = "Not Like"
' For Each oPres In Application.Presentations
' For Each oSld In oPres.Slides
For Each oSld In ActivePresentation.Slides
Sldnum = Sldnum + 1
For Each oShp In oSld.Shapes
ActiveWindow.View.GotoSlide Sldnum
oShp.Select
Call ReplaceText(oShp, FindWhat, ReplaceWith)
Next oShp
Next oSld
' Next oPres
End Sub
Sub ReplaceText(oShp As Object, FindString As String, ReplaceString As
String)
Dim oTxtRng As TextRange
Dim oTmpRng As TextRange
Dim I As Integer
Dim iRows As Integer
Dim iCols As Integer
Dim oShpTmp As Shape
' Always include the 'On error resume next' statememt below when you are
working with text range object.
' I know of at least one PowerPoint bug where it will error out - when
an image has been dragged/pasted
' into a text box. In such a case, both HasTextFrame and HasText
properties will return TRUE but PowerPoint
' will throw an error when you try to retrieve the text.
'*** On Error Resume Next ****
Select Case oShp.Type
Case 19 'msoTable
For iRows = 1 To oShp.Table.Rows.Count
For iCol = 1 To oShp.Table.Rows(iRows).Cells.Count
Set oShpTmp = oShp.Table.Rows(iRows).Cells(iCol).Shape
Call ReplaceText(oShpTmp, FindString, ReplaceString)
Next
Next
Case msoGroup 'Groups may contain shapes with text, so look within it
For I = 1 To oShp.GroupItems.Count
Call ReplaceText(oShp.GroupItems(I), FindString, ReplaceString)
Next I
Case 21 ' msoDiagram
For I = 1 To oShp.Diagram.Nodes.Count
Call ReplaceText(oShp.Diagram.Nodes(I).TextShape, FindString,
ReplaceString)
Next I
Case Else
If oShp.HasTextFrame Then
If oShp.TextFrame.HasText Then
Set oTxtRng = oShp.TextFrame.TextRange
Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _
Replacewhat:=ReplaceString,
WholeWords:=True)
Do While Not oTmpRng Is Nothing
Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _
Replacewhat:=ReplaceString,
_
After:=oTmpRng.Start +
oTmpRng.Length, _
WholeWords:=True)
Loop
End If
End If
End Select
End Sub
