Loop through all shapes in all stories not working

Peterson · #1 03-02-2018, 11:20 PM

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

Guessed · #2 03-03-2018, 01:48 AM

The first problem is the order you are stepping through when you might delete a textbox. The way your code is written you are saying: Take a line of objects, if the first object is bad, remove it and step to the object #2. BUT if you remove the first object, all the remaining objects move up the list by one spot. So potentially, you could delete only every second shape if all started with Draft. You can avoid this trap by starting at the back of the line and moving forward.

Another potential issue is that a text box and a shape with a text frame might be two different things in VBA but could appear to the user to be the same.

The next problem is that InStr doesn't return 1 if a text box contains DRAFT, it returns the position the string starts at. I"m not sure if InStr is Case Sensitive so that might also cause a non-hit when you expect a hit.

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 strText As String, i As Integer

    For Each pRange In ActiveDocument.StoryRanges    'Loop through all of the stories
      For i = pRange.ShapeRange.Count To 1 Step -1
        Set sShape = pRange.ShapeRange(i)
        If sShape.TextFrame.HasText Then
          strText = sShape.TextFrame.TextRange.Text
          If UCase(Left(strText, 5)) = "DRAFT" Then sShape.Delete
        End If
      Next i
    Next pRange
End Sub

Peterson · #3 03-03-2018, 01:23 PM

Thank you, Andrew, for not only clearly and simply explaining why the macro wasn't working, but for revising the code, too -- I appreciate it!

Peterson · #4 03-03-2018, 06:17 PM

Well, I tested the macro and it works perfectly on all body pages of the document and the headers in the first section, but it doesn't touch any section 2+ headers. I've been unable to figure out why.

I tried to rework the macro so that it iterates through just the body first, then through just the headers (it's extremely unlikely that users would ever put the draft box in any other stories but the body and header), but this attempt also failed. Here, I tried to emulate the pattern in Andrew's code: you've got a range of shapes, then you've got an individual shape in the range to inspect, then you test/delete, then iterate backwards:

Code:

      For i = rngStoryRange.ShapeRange.Count To 1 Step -1
        Set sShape = rngStoryRange.ShapeRange(i)
        
       '...do the things

      Next i 'Next sShape in the current range

...but I can't for the life of me figure out how to have a range of shapes within the header so that I can then go through each individual shape.

My hope is that there's a simple solution to this. That said, I'm providing a failed second attempt to get this to work below; it does not include my attempts to set a range of shapes, then go through each shape. But you can see that I tried to have two loops: one for the body and one for the headers.

I'm also attaching a test doc that has multiple draft boxes in multiple sections.

Code:

Sub DraftStampsDelete_25_0303_1525() 

  Dim sShape As Shape
  Dim strText As String, i As Integer
    
  For i = ActiveDocument.Sections.Count To 1 Step -1
    For Each sShape In ActiveDocument.Shapes
      If sShape.TextFrame.HasText Then
        strText = sShape.TextFrame.TextRange.Text
          If UCase(Left(strText, 5)) = "DRAFT" Then sShape.Delete
      End If
    Next sShape
  Next i

  For i = ActiveDocument.Sections.Count To 1 Step -1
    For Each sShape In ActiveDocument.Sections(i).Headers(wdHeaderFooterPrimary).Shapes
      If sShape.TextFrame.HasText Then
        strText = sShape.TextFrame.TextRange.Text
        If UCase(Left(strText, 5)) = "DRAFT" Then sShape.Delete
      End If
    Next sShape
  Next i
End Sub

Thank you.

gmayor · #5 03-03-2018, 09:36 PM

Try the following, which loops through all the story ranges in the document.

Code:

Sub DraftStampsDelete_25_0303_1525()
Dim oStory As Range
Dim sShape As Shape
Dim strText As String
Dim i As Integer
    For Each oStory In ActiveDocument.StoryRanges
        For i = oStory.ShapeRange.Count To 1 Step -1
            Set sShape = oStory.ShapeRange(i)
            If sShape.TextFrame.HasText Then
                strText = sShape.TextFrame.TextRange.Text
                If UCase(Left(strText, 5)) = "DRAFT" Then sShape.Delete
            End If
        Next i
        If oStory.StoryType <> wdMainTextStory Then
            While Not (oStory.NextStoryRange Is Nothing)
                Set oStory = oStory.NextStoryRange
                For i = oStory.ShapeRange.Count To 1 Step -1
                    Set sShape = oStory.ShapeRange(i)
                    If sShape.TextFrame.HasText Then
                        strText = sShape.TextFrame.TextRange.Text
                        If UCase(Left(strText, 5)) = "DRAFT" Then sShape.Delete
                    End If
                Next i
            Wend
        End If
    Next oStory
lbl_Exit:
    Set oStory = Nothing
    Set sShape = Nothing
    Exit Sub
End Sub

Peterson · #6 03-04-2018, 11:02 AM

Graham -- as you already know, this works flawlessly. Thank you so much your help!

Thread Tools
Show Printable Version Email this Page
Display Modes
Linear Mode Switch to Hybrid Mode Switch to Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Loop through worksheet range to show / hide shapes.	wlcdo2	Excel Programming	2	02-22-2017 05:10 PM
Can a word doc have 2 continuous 'stories' across multiple pages?	Cosmo	Word	1	06-19-2014 01:09 PM
While loop not working right	Cbrehm	Excel Programming	0	05-11-2011 11:05 AM
Where did map shapes go?	SueK	PowerPoint	1	01-20-2011 04:30 AM
PPT 2010 - Video Shapes and Effects Not Working	stepper	PowerPoint	2	01-13-2011 12:44 PM