#1
|
|||
|
|||
Loop through all shapes in all stories not working
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 |
#2
|
||||
|
||||
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
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#3
|
|||
|
|||
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!
|
#4
|
|||
|
|||
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 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 |
#5
|
||||
|
||||
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
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#6
|
|||
|
|||
Graham -- as you already know, this works flawlessly. Thank you so much your help!
|
Thread Tools | |
Display Modes | |
|
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 |