Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 11-21-2018, 12:29 PM
B4rikuda B4rikuda is offline Infinite Loop when Finding Styles Windows 7 64bit Infinite Loop when Finding Styles Office 2013
Novice
Infinite Loop when Finding Styles
 
Join Date: Nov 2018
Posts: 2
B4rikuda is on a distinguished road
Default Infinite Loop when Finding Styles


Hello,

I have been working on a project to help my office to streamline the formatting of our documents. I have created a template for us to use but when we paste documents that already exist, the styles don't update to match the template but rather keep the source formatting. In order to help update the Styles, I scrapped together this code to search through the document to find all Heading Styles and reapply the new Styles to the pasted document. I doubt I am doing this in the most efficient way but it has worked so far.

The issue I run into is this: If the code is looking for all the Heading 1 styles and the last style on the document is Heading 1, it runs into an infinite loop. If it is a different style, it works properly. Can anybody help me to end this madness?

Code:
Sub ChangeActiveDocument()

Dim Answer As String, Bln As Boolean
Bln = True
Dim i As Integer
    
    'Looks for any styles in a Pasted document called Heading 1, 2, or 3 and reapplies the style
    With ActiveDocument
        While Bln
            'Find and select Heading 1
            Set currentRange = ActiveDocument.Range
            currentRange.Find.ClearFormatting
            currentRange.Find.Style = wdStyleHeading1
            currentRange.Find.Wrap = wdFindStop
            currentRange.Find.Forward = True
            currentRange.Find.Text = ""
            i = 1
            bFind = currentRange.Find.Execute

            'Reapply the Heading 1 Style to the selected Heading 1
            Do While bFind 'here is the endless loop
                 'Answer = MsgBox(i & "wdStyleHeading1 " & currentRange.Text, vbOKCancel)
                 currentRange.Style = ActiveDocument.Styles(wdStyleHeading1)
                 currentRange.SetRange currentRange.End, currentRange.End
                 i = i + 1
                 'If currentRange.End = True Then Exit Do
                 bFind = currentRange.Find.Execute
            Loop
            
            'Find and select Heading 2
            Set currentRange = ActiveDocument.Range
            currentRange.Find.ClearFormatting
            currentRange.Find.Style = wdStyleHeading2
            currentRange.Find.Wrap = wdFindStop
            currentRange.Find.Forward = True
            currentRange.Find.Text = ""
            bFind = currentRange.Find.Execute

            'Reapply the Heading 1 Style to the selected Heading 2
            Do While bFind 'here is the endless loop
                 'Answer = MsgBox(i & "wdStyleHeading2 " & currentRange.Text, vbOKCancel)
                 currentRange.Style = ActiveDocument.Styles(wdStyleHeading2)
                 currentRange.SetRange currentRange.End, currentRange.End
                 i = i + 1
                 bFind = currentRange.Find.Execute
            Loop
            
            'Find and select Heading 3
            Set currentRange = ActiveDocument.Range
            currentRange.Find.ClearFormatting
            currentRange.Find.Style = wdStyleHeading3
            currentRange.Find.Wrap = wdFindStop
            currentRange.Find.Forward = True
            currentRange.Find.Text = ""
            bFind = currentRange.Find.Execute

            'Reapply the Heading 1 Style to the selected Heading 3
            Do While bFind 'here is the endless loop
                 'Answer = MsgBox(i & "wdStyleHeading3 " & currentRange.Text, vbOKCancel)
                 currentRange.Style = ActiveDocument.Styles(wdStyleHeading3)
                 currentRange.SetRange currentRange.End, currentRange.End
                 i = i + 1
                 bFind = currentRange.Find.Execute
            Loop
            
        Bln = False
        Wend
    End With
    
    'Looks for any styles in a Pasted document called Epic Title and changes it to Heading 3
    With ActiveDocument
        Set currentRange = ActiveDocument.Range
        currentRange.Find.ClearFormatting
        currentRange.Find.Style = "Epic Title"
        currentRange.Find.Wrap = wdFindStop
        currentRange.Find.Forward = True
        currentRange.Find.Text = ""
        i = 1
        bFind = currentRange.Find.Execute

        Do While bFind 'here is the endless loop
             currentRange.Style = ActiveDocument.Styles(wdStyleHeading3)
             currentRange.SetRange currentRange.End, currentRange.End
             bFind = currentRange.Find.Execute
        Loop
    End With
    
    'Looks for any styles in a Pasted document called Main Topic and changes it to Heading 1
    With ActiveDocument
        Set currentRange = ActiveDocument.Range
        currentRange.Find.ClearFormatting
        currentRange.Find.Style = "Main Topic"
        currentRange.Find.Wrap = wdFindStop
        currentRange.Find.Forward = True
        currentRange.Find.Text = ""
        i = 1
        bFind = currentRange.Find.Execute

        Do While bFind 'here is the endless loop
             currentRange.Style = ActiveDocument.Styles(wdStyleHeading1)
             currentRange.SetRange currentRange.End, currentRange.End
             bFind = currentRange.Find.Execute
        Loop
    End With
    
End Sub

Last edited by macropod; 11-21-2018 at 03:32 PM. Reason: Replaced QUOTE tags with CODE tags
Reply With Quote
  #2  
Old 11-21-2018, 03:46 PM
macropod's Avatar
macropod macropod is offline Infinite Loop when Finding Styles Windows 7 64bit Infinite Loop when Finding Styles Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

Try something based on:
Code:
Sub ChangeActiveDocument()
Application.ScreenUpdating = False
Dim ArrStlFnd(), ArrStlRep(), i As Long
ArrStlFnd = Array("Heading 1", "Heading 2", "Heading 3", "Main Topic", "Epic Title")
ArrStlRep = Array("Heading 1", "Heading 2", "Heading 3", "Heading 1", "Heading 3")
For i = 0 To UBound(ArrStlFnd)
  With ActiveDocument.Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ""
      .Replacement.Text = ""
      .Forward = True
      .Format = True
      .Style = ArrStlFnd(i)
      .Wrap = wdFindStop
      .Execute
    End With
    Do While .Find.Found
      .Style = ArrStlRep(i)
      .ParagraphFormat.Reset
      .Font.Reset
      If .Information(wdWithInTable) = True Then
        If .End = .Cells(1).Range.End - 1 Then
          .End = .Cells(1).Range.End
          .Collapse wdCollapseEnd
          If .Information(wdAtEndOfRowMarker) = True Then
            .End = .End + 1
          End If
        End If
      End If
      If .End = ActiveDocument.Range.End Then Exit Do
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
Next
Application.ScreenUpdating = True
End Sub
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #3  
Old 11-21-2018, 04:19 PM
B4rikuda B4rikuda is offline Infinite Loop when Finding Styles Windows 7 64bit Infinite Loop when Finding Styles Office 2013
Novice
Infinite Loop when Finding Styles
 
Join Date: Nov 2018
Posts: 2
B4rikuda is on a distinguished road
Default

That worked wonderfully, macropod! Thank you!
Reply With Quote
  #4  
Old 11-21-2018, 04:27 PM
Guessed's Avatar
Guessed Guessed is offline Infinite Loop when Finding Styles Windows 10 Infinite Loop when Finding Styles Office 2016
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

I would approach this task from a different direction.

Firstly, if you have control of the receiving file PRIOR to introducing the other content, add a couple of aliases to the heading styles so that the conversion of Epic Title and Main Topic to headings happens automatically as you paste.

Add an alias to Heading 3 by modifying the style for Heading 3 so its name is "Heading 3,Epic Title". Do the same for Heading 1 so its name becomes "Heading 1,Main Topic".

Note: You can't add an alias if that style name already exists in the document so it has to happen BEFORE pasting in the content from the other source. But once it is done, anything that was styled with either Heading 3 OR Epic Title will paste into the document as Heading 3.

So then, all that remains is the question you posted about. I would rewrite that part of the macro along the following lines.
Code:
Sub ChangeActiveDocument()
  Dim aRng As Range, iHeadStyleID As Integer
  For iHeadStyleID = -4 To -2    '-4=wdStyleHeading3, -2=wdStyleHeading1
    Set aRng = ActiveDocument.Range
    With aRng.Find
      .ClearFormatting
      .Style = iHeadStyleID
      .Wrap = wdFindStop
      .Forward = True
      .Text = ""
      Do While .Execute
        aRng.ParagraphFormat.Reset
        aRng.Font.Reset
      Loop
    End With
  Next
End Sub
__________________
Andrew Lockton
Chrysalis Design, Melbourne Australia
Reply With Quote
Reply

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Infinite Loop when Finding Styles Infinite loops occurring in find and replace functions in word macro Thefirstfish` Word VBA 5 04-06-2017 07:18 PM
MACRO in infinite loop when it encounters user defined figure label photoval Word VBA 3 02-02-2016 08:26 PM
Outlook 2013 - caught in an infinite loop on startup borderfox Outlook 0 07-26-2015 01:40 PM
Infinite Loop when Finding Styles Finding and replacing fonts and styles Adriano Word VBA 10 03-17-2013 07:08 PM
'Infinite Loop' error with Infopath 2010 Debbie25 Misc 2 05-18-2011 08:38 AM

Other Forums: Access Forums

All times are GMT -7. The time now is 11:46 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