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

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

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()

Answer 2

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 3

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!