Problem with find method and changing text boxes dimesion

[Rosenrot]

Hi everyone,

I’m working on the macro the aim of which is to search for certain words (Note; Source) within the text boxes. In other words, the macro should change the dimension of text boxes containing these particular words in the following way:

.Width = 773
.Height = 24
.Left = 15
.Top = 520

I have already created the macro but I noticed it crashes VBA and the entire PowerPoint every time I run it. As a result, I cannot even find out whether the code is properly written.

Do you have any ideas how to fix this problem or how to modify the code, so that it does not harm PowerPoint?

The code is as follows:


Sub NoteandSource()
Dim oSld As Slide
Dim oShp As Shape
Dim TR As TextRange
Dim TRFind1 As TextRange
Dim TRFind2 As TextRange

For Each oSld In ActivePresentation.Slides
For Each oShp In oSld.Shapes
If oShp.HasTextFrame Then
If oShp.TextFrame.HasText Then
Set TR = oShp.TextFrame.TextRange
Set TRFind1 = TR.Find(FindWhat:="Note")
Set TRFind2 = TR.Find(FindWhat:="Source")

Do While Not (TRFind1 Is Nothing)
Do While Not (TRFind2 Is Nothing)

With oShp
.Width = 773
.Height = 24
.Left = 15
.Top = 520
End With

Loop
Loop

End If
End If
Next
Next

End Sub

[John Wilson]

It's not exactly "harming" PowerPoint, your code will go into an endless loop. You need to start the search in the loop after the point it was last found.

I would also do the two searches separately.


Sub NoteandSource()
Dim oSld As Slide
Dim oShp As Shape
Dim TR As TextRange
Dim TRFind1 As TextRange
Dim TRFind2 As TextRange


For Each oSld In ActivePresentation.Slides
For Each oShp In oSld.Shapes
If oShp.HasTextFrame Then
If oShp.TextFrame.HasText Then


Set TR = oShp.TextFrame.TextRange
Set TRFind1 = TR.Find(FindWhat:="Note", WholeWords:=True)
Do While Not (TRFind1 Is Nothing)
Set TRFind1 = TR.Find(FindWhat:="Note", After:=TRFind1.Start + TRFind1.Length, WholeWords:=True)
With oShp
.Width = 773
.Height = 24
.Left = 15
.Top = 520
End With
Loop
Set TRFind2 = TR.Find(FindWhat:="Source", WholeWords:=True)
Do While Not (TRFind2 Is Nothing)
Set TRFind2 = TR.Find(FindWhat:="Source", After:=TRFind2.Start + TRFind2.Length, WholeWords:=True)
With oShp
.Width = 773
.Height = 24
.Left = 15
.Top = 520
End With
Loop
End If
End If
Next
Next
End Sub

[Rosenrot]

It works just perfectly, thank you for your help John!