Vba code to replace with chr(13) with space for selected text in powerpoint

[shoun2502]

Dear all,

I am currently working on this code and I need to replace chr(13) with space for the selected text and not for the whole slide. The code below works well with all shapes in active presentation .

The code is as follows :

Sub Removepb()
Dim otxR As TextRange
Dim osld As Slide
Dim oshp As Shape
For Each osld In ActivePresentation.Slides
For Each oshp In osld.Shapes
If Not oshp.Type = msoPlaceholder Then
If oshp.HasTextFrame Then
If oshp.TextFrame.HasText Then
Set otxR = oshp.TextFrame.TextRange
otxR.Text = Replace(otxR.Text, Chr(13), "")
End If
End If
End If
Next oshp
Next osld
End Sub

The suggestions would be welcome to customize this subroutine to run on the selected Text inside a shape.

Regards

 

[Yongle]

Select a shape containing text and run the code

Sub ReplaceText()
    Dim Shp As Shape
    On Error Resume Next
    For Each Shp In ActiveWindow.Selection.ShapeRange
        If Shp.HasTextFrame Then
            With Shp.TextFrame.TextRange
                .Text = Replace(.Text, Chr(10), "") 
            End With
            Exit For
        End If
    Next Shp
    If Err.Number > 0 Then MsgBox "no shape selected"
End Sub

Notes
.Text = Replace(.Text, Chr(10), "")
- your original code which you said does exactly what you want

On Error Resume Next
- prevents the code failing if run when nothing selected

 

[shoun2502]

Hi Yongle,

The code is not working

Thanks for the reply.

 

[shoun2502]

Hi yongle,

I have used your subroutine with slight modificactions as mentioned below

Sub ReplaceText()
    Dim Shp As Shape
    On Error Resume Next
    For Each Shp In ActiveWindow.Selection.ShapeRange
        If Shp.HasTextFrame Then
            With Shp.TextFrame.TextRange
                .Text = Replace(.Text, Chr(13), "")
            End With
            Exit For
        End If
    Next Shp
    If Err.Number > 0 Then MsgBox "no shape selected"
End Sub

But the issue it is replacing all text in the shape rather than the selected text.

Please help if you could check that.


Thanks for your reply

 

[Yongle]

Here you go
- select a single block of text within a shape and run the code

Sub ReplaceSelectedText()
    Dim Shp As Shape, Pos As Long, LenSelTxt As Long, lenShpTxt As Long
    Dim SelTxt As String, shpTxt As String, leftTxt As String, rightTxt As String
    
    On Error Resume Next
    For Each Shp In ActiveWindow.Selection.ShapeRange
[COLOR=#006400][I]    'selected text[/I][/COLOR]
        SelTxt = ActiveWindow.Selection.TextRange
        LenSelTxt = Len(SelTxt)
[I][COLOR=#006400]    'shape text[/COLOR][/I]
        shpTxt = Shp.TextFrame.TextRange.Text
        lenShpTxt = Len(shpTxt)
 [COLOR=#006400][I]   'to left and right of selected text[/I][/COLOR]
        Pos = InStr(1, shpTxt, SelTxt, vbTextCompare)
        leftTxt = Left(shpTxt, Pos - 1)
        rightTxt = Right(shpTxt, lenShpTxt - Pos - LenSelTxt + 1)
 [I][COLOR=#006400]   'replace text and reassemble[/COLOR][/I]
        SelTxt = Replace(SelTxt, Chr(10), " ")
        shpTxt = leftTxt & SelTxt & rightTxt
        Shp.TextFrame.TextRange.Text = shpTxt
        Exit For
    Next Shp
End Sub

 

[shoun2502]

Thanks Yongle

Saved a lot of time indeed!

 

[Yongle]

Thanks for the feedback