I'm trying to cobble together a macro that finds all text boxes that contain the word "draft" and deletes them. Using a loop structure by macropod (many thanks!), I've gotten to the point where I can get through all stories; however, the macro isn't looping through all shapes in each story -- it addresses just one before moving to the next story. What am I doing wrong?
Code:
Sub DraftStampDelete0301()
' This macro removes all text boxes containing "DRAFT" from a document.
' StoryRanges loop by macropod -- http://www.vbaexpress.com/forum/archive/index.php/t-27391.html
' Shapes code adapted from https://www.experts-exchange.com/questions/27274592/Word-VBA-access-Text-box-in-header.html
Dim pRange As Range ' The story range, to loop through each story in the document
Dim sShape As Shape ' For the text boxes, which Word considers shapes
Dim strTextBoxText As String ' To test whether text in a text box contains "DRAFT"
'Loop through all of the stories
For Each pRange In ActiveDocument.StoryRanges
Do
'Loop through all shapes in the current story, to find the text boxes
For Each sShape In pRange.ShapeRange
'Test to see if the shape a text box (then see if it contains "DRAFT," then delete it, if so)
If sShape.Type = msoTextBox Then
Debug.Print sShape.Name
'If the shape is a text box, then select it
sShape.Select
'Determine if the text box has "DRAFT": retrieve the text...
Selection.ShapeRange.TextFrame.TextRange.Select
'...and assign it to the strTextBox variable, to be dropped into an InStr function
strTextBoxText = Selection.Text
Debug.Print strTextBoxText
'...and test the string
If InStr(strTextBoxText, "DRAFT") = 1 Then '' InStr function returns a 1 if found, 0 if not
Debug.Print "Draft found in text box"
'...and delete it if it's a draft stamp
sShape.Delete
End If
End If
Next 'sShape
Set pRange = pRange.NextStoryRange
Loop Until pRange Is Nothing
Next
End Sub