Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 03-02-2018, 11:20 PM
Peterson Peterson is offline Loop through all shapes in all stories not working Windows 7 64bit Loop through all shapes in all stories not working Office 2016
Competent Performer
Loop through all shapes in all stories not working
 
Join Date: Jan 2017
Posts: 141
Peterson is on a distinguished road
Default 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
Reply With Quote
  #2  
Old 03-03-2018, 01:48 AM
Guessed's Avatar
Guessed Guessed is offline Loop through all shapes in all stories not working Windows 10 Loop through all shapes in all stories not working Office 2013
Expert
 
Join Date: Mar 2010
Location: Canberra/Melbourne Australia
Posts: 3,932
Guessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant future
Default

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
Reply With Quote
  #3  
Old 03-03-2018, 01:23 PM
Peterson Peterson is offline Loop through all shapes in all stories not working Windows 7 64bit Loop through all shapes in all stories not working Office 2016
Competent Performer
Loop through all shapes in all stories not working
 
Join Date: Jan 2017
Posts: 141
Peterson is on a distinguished road
Default

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!
Reply With Quote
  #4  
Old 03-03-2018, 06:17 PM
Peterson Peterson is offline Loop through all shapes in all stories not working Windows 7 64bit Loop through all shapes in all stories not working Office 2016
Competent Performer
Loop through all shapes in all stories not working
 
Join Date: Jan 2017
Posts: 141
Peterson is on a distinguished road
Default

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.
Attached Files
File Type: docx Draft Stamp Delete Test Doc4.docx (87.5 KB, 12 views)
Reply With Quote
  #5  
Old 03-03-2018, 09:36 PM
gmayor's Avatar
gmayor gmayor is offline Loop through all shapes in all stories not working Windows 10 Loop through all shapes in all stories not working Office 2016
Expert
 
Join Date: Aug 2014
Posts: 4,101
gmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud of
Default

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
Reply With Quote
  #6  
Old 03-04-2018, 11:02 AM
Peterson Peterson is offline Loop through all shapes in all stories not working Windows 7 64bit Loop through all shapes in all stories not working Office 2016
Competent Performer
Loop through all shapes in all stories not working
 
Join Date: Jan 2017
Posts: 141
Peterson is on a distinguished road
Default

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

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Loop through all shapes in all stories not working Loop through worksheet range to show / hide shapes. wlcdo2 Excel Programming 2 02-22-2017 05:10 PM
Loop through all shapes in all stories not working 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
Loop through all shapes in all stories not working Where did map shapes go? SueK PowerPoint 1 01-20-2011 04:30 AM
Loop through all shapes in all stories not working PPT 2010 - Video Shapes and Effects Not Working stepper PowerPoint 2 01-13-2011 12:44 PM

Other Forums: Access Forums

All times are GMT -7. The time now is 06:05 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft