How to modify text in Powerpoint via Excel VBA without changing style - vba

Question

I am trying to replace a set of tags in the text of a powerpoint slide from Excel using VBA. I can get the slide text as follows:
Dim txt as String
txt = pptSlide.Shapes(jj).TextFrame.TextRange.Characters.text
I then run through replacing my tags with the requested values. However when I set do
pptSlide.Shapes(jj).TextFrame.TextRange.Characters.text = txt
Problem: All the formatting which the user has set up in the text box is lost.
Background:
The shape object is msoPlaceHolder and contains a range of text styles including bullet points with tags which should be replaced with numbers for instance. The VBA should be unaware of this formatting and need only concern itself with the text replacement.
Can anyone tell me on how to modify the text while keeping the style set up by the user.
Thanks.
Am using Office 2010 if that is helpful.

Answer 1

The solution by Krause is close but the FIND method returns a TextRange object that has to be checked. Here is a complete subroutine that replaces FROM-string with TO-string in an entire presentation, and DOESN'T mess up the formatting!
Sub Replace_in_Shapes_and_Tables(pPPTFile As Presentation, sFromStr As String, sToStr As String)
Dim sld As Slide
Dim shp As Shape
Dim i As Long
Dim j As Long
Dim m As Long
Dim trFoundText As TextRange
On Error GoTo Replace_in_Shapes_and_Tables_Error
For Each sld In pPPTFile.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then ' only perform action on shape if it contains the target string
Set trFoundText = shp.TextFrame.TextRange.Find(sFromStr)
If Not (trFoundText Is Nothing) Then
m = shp.TextFrame.TextRange.Find(sFromStr).Characters.Start
shp.TextFrame.TextRange.Characters(m).InsertBefore (sToStr)
shp.TextFrame.TextRange.Find(sFromStr).Delete
End If
End If
End If
If shp.HasTable Then
For i = 1 To shp.Table.Rows.Count
For j = 1 To shp.Table.Columns.Count
Set trFoundText = shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Find(sFromStr)
If Not (trFoundText Is Nothing) Then
m = shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Find(sFromStr).Characters.Start
shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Characters(m).InsertBefore (sToStr)
shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Find(sFromStr).Delete
End If
Next j
Next i
End If
Next shp
Next sld
For Each shp In pPPTFile.SlideMaster.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
Set trFoundText = shp.TextFrame.TextRange.Find(sFromStr)
If Not (trFoundText Is Nothing) Then
m = shp.TextFrame.TextRange.Find(sFromStr).Characters.Start
shp.TextFrame.TextRange.Characters(m).InsertBefore (sToStr)
shp.TextFrame.TextRange.Find(sFromStr).Delete
End If
End If
End If
If shp.HasTable Then
For i = 1 To shp.Table.Rows.Count
For j = 1 To shp.Table.Columns.Count
Set trFoundText = shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Find(sFromStr)
If Not (trFoundText Is Nothing) Then
m = shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Find(sFromStr).Characters.Start
shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Characters(m).InsertBefore (sToStr)
shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Find(sFromStr).Delete
End If
Next j
Next i
End If
Next shp
On Error GoTo 0
Exit Sub
Replace_in_Shapes_and_Tables_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Replace_in_Shapes_and_Tables of Module modA_Code"
Resume
End Sub

Answer 2

While what Steve Rindsberg said is true I think I have come up with a decent workaround. It is by no means pretty but it gets the job done without sacrificing the formatting. It uses Find functions and Error Controlling for any text box that doesn't have the variable you are looking to change out.
i = 1
Set oPs = oPa.ActivePresentation.Slides(oPa.ActivePresentation.Slides.Count)
j = 1
Do Until i > oPa.ActivePresentation.Slides.Count
oPa.ActivePresentation.Slides(i).Select
Do Until j > oPa.ActivePresentation.Slides(i).Shapes.Count
If oPa.ActivePresentation.Slides(i).Shapes(j).HasTextFrame Then
If oPa.ActivePresentation.Slides(i).Shapes(j).TextFrame.HasText Then
On Error GoTo Err1
If oPa.ActivePresentation.Slides(i).Shapes(j).TextFrame.TextRange.Find("[specific search term]") = "[specific search term]" Then
m = oPa.ActivePresentation.Slides(i).Shapes(j).TextFrame.TextRange.Find("[specific search term]").Characters.Start
oPa.ActivePresentation.Slides(i).Shapes(j).TextFrame.TextRange.Characters(m).InsertBefore ([replace term])
oPa.ActivePresentation.Slides(i).Shapes(j).TextFrame.TextRange.Find("[specific search term]").Delete
ExitHere:
End If
End If
End If
j = j + 1
Loop
j = 1
i = i + 1
Loop
Exit Sub
Err1:
Resume ExitHere
End Sub
Hope this helps!

Answer 3

I found the solution using the code below. It edits the notes by replacing "string to replace" with "new string". This example is not iterative and will only replace the first occurrence but it should be fairly easy to make it iterative.
$PowerpointFile = "C:\Users\username\Documents\test.pptx"
$Powerpoint = New-Object -ComObject powerpoint.application
$ppt = $Powerpoint.presentations.open($PowerpointFile, 2, $True, $False)
$ppt.Slides[3].Shapes[2].TextFrame.TextRange.Text
$ppt.Slides[3].NotesPage.Shapes[2].TextFrame.TextRange.Text
foreach($slide in $ppt.slides){
$TextRange = $slide.NotesPage.Shapes[2].TextFrame.TextRange
$find = $TextRange.Find('string to replace').Start
$TextRange.Find('string to replace').Delete()
$TextRange.Characters($find).InsertBefore('new string')
$TextRange.Text
}
$ppt.SaveAs("C:\Users\username\Documents\test2.pptx")
$Powerpoint.Quit()