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