Loop through all shapes in all stories not working

Guessed · #1 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 · #2 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 · #3 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.

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