How can I add a progress bar to this word macro

huntson
huntson used Ask the Experts™
on
Another user on this site helped my optimize my code for a macro that modifies a subtitle file.  I'd like to add a progress bar example I have found online.  I'm not exactly sure how to make Word do 2 things at the same time.  Perhaps the best approach is to encompass the main program in another loop that handles the progress bar?

Here is the main code:
Sub RemoveParaOrLineBreaks()

'use constants here instead of variables
Const staticTC = "--:--:--:--:--,--:--:--:--:--,10"
Const static_next_line = "80 80 80"
'added this
Const marker_code = "C2N03"

Dim bStop As Boolean
'variant for previous and next slide number
Dim vSlide As Variant, vNext As Variant
'we need 3 range variables:
Dim rSlide As Range, rNext As Range, rDoc As Range
'start and end long integer markers for rSlide range:
Dim iStart As Long, iEnd As Long
'length of slide number line:
Dim iPos As Long
'variable to hold replacement text:
Dim sText As String

'initial setup
Set rDoc = ActiveDocument.Range
'create rSlide initially as zero size. NB do NOT initialise both rNext and rSlide to the whole document range as well, since
'this non-obviously makes them both the same range, and changing one will change the other

Set rSlide = ActiveDocument.Range(0, 0)

'set up the find parameters before you loop through the document, so you don't repeat unnecessary setup on each loop:
    With rDoc.Find
    .ClearFormatting
    .Format = False
    .Wrap = wdFindStop
    .Forward = True
    .MatchWildcards = False
    End With

Do
'find the next (or first) slide, using carriage-return number number number number
    With rDoc.Find
            .Execute FindText:="^p^#^#^#^#"
            If .found Then
                'set end of previous slide range
                rSlide.End = rDoc.Start - 1
                'set range of rNext to the temporary values for rDoc that result from the "find", and then extend to include 4 more characters
                Set rNext = ActiveDocument.Range(rDoc.Start, rDoc.End)
                rNext.End = rNext.End + 4
               'grab the resulting text to variable vNext
                vNext = rNext.Text
                    'check the sixth character and include it as part of the slide number if it's not a space, using VBA string function Mid
                    If Mid(vNext, 6, 1) <> Chr(32) Then
                    vNext = Mid(vNext, 2, 5)
                    Else
                    'otherwise just use the first four characters (omitting the carriage return at the start)
                    vNext = Mid(vNext, 2, 4)
                    End If
            'if no further slide numbers found, then exit at end of loop
            Else
            bStop = True
            'set final slide range.. assuming text is in a table, as in your example, this needs to be the end of the table cell
            'if text is not in a table then use activedocument.range.end-1
            rSlide.End = rSlide.Cells(1).Range.End - 2
            End If
    End With
'process the previous slide -
'this eliminates all the stuff with deciding how many sentences there are etc, because we are
'simply replacing the previous slide's range with new text

    If rSlide.Start > 0 Then 'check start >0 so we don't try to process anything before slide 1
    
    'work where possible with a string variable rather than a document range. MUCH faster
    sText = rSlide.Text
    
    'cut the initial number line altogether by finding a colon and carriage return
    iPos = InStr(sText, ":" & Chr(13))
    sText = Mid(sText, iPos + 1) ' returns everything to the right of iPos+1
    
    'remove unwanted double carriage returns
    While InStr(sText, Chr(13) & Chr(13))
    sText = Replace(sText, Chr(13) & Chr(13), Chr(13))
    Wend
    
    'cut any final CR
    If Right(sText, 1) = Chr(13) Then sText = Left(sText, Len(sText) - 1)
    
    'add marker code at each text line break - replacing need to count lines etc
    sText = Replace(sText, Chr(13), Chr(11) & marker_code & "  ")
    
    'assemble full text, including the sText we have already built
    sText = vSlide & " : " & staticTC & Chr(11) & static_next_line & Chr(11) & marker_code & " " & _
            vSlide & " : " & sText & Chr(13) & Chr(13)
            
            
    'replace the text in the pre-defined range rSlide. Much quicker than using the built-in Word find and replace
    rSlide.Text = sText
    End If

'set new start point for previous slide's range
rSlide.Start = rSlide.End + 1
'make vNext into vSlide
vSlide = vNext
    
Loop Until bStop
        
End Sub

Open in new window



Here is the progress bar code:
Option Explicit

Sub StatusBar()
Dim x As Integer
Dim MyTimer As Double
'Change this loop as needed.
For x = 1 To 250

'Dummy Loop here just to waste time.
'Replace this loop with your actual code.
MyTimer = Timer
Do
Loop While Timer - MyTimer < 0.03
Application.StatusBar = "Progress: " & x & " of 250: " & Format(x / 250, "Percent")
DoEvents

Next x
Application.StatusBar = False
End Sub

Open in new window

Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Neil FlemingConsultant and developer

Commented:
Hi.. The following does what you want. You don't need the timer loop or anything. I just added code to retrieve the current page being processed and stuck it in the statusbar. Also some new variables: one for current page, one for previous, and one to record the start time of the routine.

HOWEVER, there is a time penalty for doing this. In order to get the status bar to update in real time, you need to call the VBA "DoEvents" built-in function, which yields control of your PC to any pending system events.

So when I ran this just now on my 16 page dummy, it took 20 seconds as opposed to 7 without the status updater. How much time is wasted will depend on what else is going on on your PC. I'll see if there's a faster way to achieve the same thing, but there may not be.

Sub RemoveParaOrLineBreaks()

'use constants here instead of variables
Const staticTC = "--:--:--:--,--:--:--:--,10"
Const static_next_line = "80 80 80"
'added this
Const marker_code = "C2N03"

'removed a lot of unused variables, and renamed the ones you need

'It's a good idea to name your variables so they are easy to identify.. eg bStop is boolean, rNext is a range, sText is a string etc
Dim bStop As Boolean
'variant for previous and next slide number
Dim vSlide As Variant, vNext As Variant
'we need 3 range variables:
Dim rSlide As Range, rNext As Range, rDoc As Range
'start and end long integer markers for rSlide range:
Dim iStart As Long, iEnd As Long
'length of slide number line, and current/previous page
Dim iPos As Long, iPage As Long, iPrev As Long
'variable to hold replacement text:
Dim sText As String
'timer variable
Dim uTime As Double

'start timer
uTime = Timer
'trap errors:
On Error GoTo errortrap
'turn off the screen
allOff

'initial setup
Set rDoc = ActiveDocument.Range
'create rSlide initially as zero size. NB do NOT set both rNext and rSlide to the whole document range, since
'this non-obviously makes them both the same range, and changing one will change the other

Set rSlide = ActiveDocument.Range(0, 0)

'XXX set up the find parameters before you loop through the document, so you don't repeat unnecessary setup on each loop:
    With rDoc.Find
    .ClearFormatting
    .Format = False
    .Wrap = wdFindStop
    .Forward = True
    .MatchWildcards = False
    End With

Do
'find the next slide
    With rDoc.Find
            .Execute FindText:="^p^#^#^#^#"
            If .found Then
                'set end of previous slide range
                rSlide.End = rDoc.Start - 1
                'set range of rnext
                Set rNext = ActiveDocument.Range(rDoc.Start, rDoc.End)
                rNext.End = rNext.End + 4
                vNext = rNext.Text
                    'check the sixth character and include it if it's not a space, using VBA string function Mid
                    If Mid(vNext, 6, 1) <> Chr(32) Then
                    vNext = Mid(vNext, 2, 5)
                    Else
                    'otherwise just use the first four characters (omitting the carriage return at the start)
                    vNext = Mid(vNext, 2, 4)
                    End If
            'if nothing found, then exit at end of loop
            Else
            bStop = True
            'set final slide range.. assuming text is in a table, as in your example, this needs to be the end of the table cell
            'if text is not in a table then use activedocument.range.end-1
            rSlide.End = rSlide.Cells(1).Range.End - 2
            End If
    End With
'process the previous slide -
'this eliminates all the stuff with deciding how many sentences there are etc, because we are
'simply replacing the previous slide's range with new text

    If rSlide.Start > 0 Then 'check start >0 so we don't try to process anything before slide 1
    
    'work where possible with a string variable rather than a document range. MUCH faster
    sText = rSlide.Text
    
    'cut the number line
    iPos = InStr(sText, ":" & Chr(13))
    sText = Mid(sText, iPos + 1)
    
    'remove unwanted carriage returns
    While InStr(sText, Chr(13) & Chr(13))
    sText = Replace(sText, Chr(13) & Chr(13), Chr(13))
    Wend
    
    'cut any final CR
    If Right(sText, 1) = Chr(13) Then sText = Left(sText, Len(sText) - 1)
    
    'add marker code at each text line break
    sText = Replace(sText, Chr(13), Chr(11) & marker_code & "  ")
    
    'assemble full text, including existing sText
    sText = vSlide & " : " & staticTC & Chr(11) & static_next_line & Chr(11) & marker_code & " " & _
            vSlide & " : " & sText & Chr(13) & Chr(13)
            
            
    'replace the text in the pre-defined range for the slide. Much quicker than using the built-in find and replace
    rSlide.Text = sText
    End If

'set new start point for previous slide's range
rSlide.Start = rSlide.End + 1
'make vNext into vSlide
vSlide = vNext

'get current page
iPage = rSlide.Information(wdActiveEndAdjustedPageNumber)
'update status bar if new page
    If iPage > iPrev Then
    Application.StatusBar = "Processing page " & iPage
    'set new previous page
    iPrev = iPage
    'process "events" queue to force statusbar update
    DoEvents
    End If
Loop Until bStop
allOn
'exit routine if all ok

Application.StatusBar = "All pages processed in " & Format(Timer - uTime, "0.00") & " seconds."
Exit Sub
'handle error if not ok
errortrap:
allOn
MsgBox ("An error has occurred on page " & iPage)
End Sub

Open in new window

Consultant and developer
Commented:
Just to clarify, this is the new bit:
'get current page for range rSlide
iPage = rSlide.Information(wdActiveEndAdjustedPageNumber)
'update status bar if new page
    If iPage > iPrev Then
    Application.StatusBar = "Processing page " & iPage
    'set new previous page
    iPrev = iPage
    'process "events" queue to force statusbar update (this causes the time penalty)
    DoEvents
    End If
Loop Until bStop

Open in new window

Neil FlemingConsultant and developer

Commented:
The other thing that will speed up your code is to close all other word documents.

Just did that and I am current getting 18 seconds with the progress updater, and 10 seconds without it, on a 16-page document.
Exploring SQL Server 2016: Fundamentals

Learn the fundamentals of Microsoft SQL Server, a relational database management system that stores and retrieves data when requested by other software applications.

Neil FlemingConsultant and developer

Commented:
Ah. Interesting. The thing that speeds the code up more than ANYTHING, I discover, is eliminating the Word table in which you currently have the text. I converted the table to text and enlarged the file to 50 pages.

Then I I tweaked the code to handle both a table and ordinary word text. A 50 page document with no table now processes in 7.93 seconds on my laptop. This is probably because we're saving the time overhead from Word adjusting the table size, even with screen updates turned off.

Image3.jpg
Sub RemoveParaOrLineBreaks()

'use constants here instead of variables
Const staticTC = "--:--:--:--,--:--:--:--,10"
Const static_next_line = "80 80 80"
'added this
Const marker_code = "C2N03"

Dim bStop As Boolean
'variant for previous and next slide number
Dim vSlide As Variant, vNext As Variant
'3 range variables:
Dim rSlide As Range, rNext As Range, rDoc As Range
'start and end long integer markers for rSlide range:
Dim iStart As Long, iEnd As Long
'length of slide number line, and current/previous page
Dim iPos As Long, iPage As Long, iPrev As Long
'variable to hold replacement text:
Dim sText As String
'timer variable
Dim uTime As Double

'start timer
uTime = Timer
'trap errors:
On Error GoTo errortrap
'turn off the screen
allOff

'initial setup
Set rDoc = ActiveDocument.Range
'create rSlide initially as zero size. NB do NOT set both rNext and rSlide to the whole document range, since
'this non-obviously makes them both the same range, and changing one will change the other

Set rSlide = ActiveDocument.Range(0, 0)

'set up the find parameters before you loop through the document, so you don't repeat unnecessary setup on each loop:
    With rDoc.Find
    .ClearFormatting
    .Format = False
    .Wrap = wdFindStop
    .Forward = True
    .MatchWildcards = False
    End With

Do
'find the next slide
    With rDoc.Find
            .Execute FindText:="^p^#^#^#^#"
            If .found Then
                'set end of previous slide range
                rSlide.End = rDoc.Start - 1
                'set range of rnext
                Set rNext = ActiveDocument.Range(rDoc.Start, rDoc.End)
                rNext.End = rNext.End + 4
                vNext = rNext.Text
                    'check the sixth character and include it if it's not a space, using VBA string function Mid
                    If Mid(vNext, 6, 1) <> Chr(32) Then
                    vNext = Mid(vNext, 2, 5)
                    Else
                    'otherwise just use the first four characters (omitting the carriage return at the start)
                    vNext = Mid(vNext, 2, 4)
                    End If
            'if nothing found, then exit at end of loop
            Else
            bStop = True
            'set final slide range.. assuming text is in a table, as in your example, this needs to be the end of the table cell
            'if text is not in a table then use activedocument.range.end-1
                If rSlide.Tables.Count = 0 Then
                rSlide.End = ActiveDocument.Range.End - 1
                Else
                rSlide.End = rSlide.Cells(1).Range.End - 2
                End If
            End If
    End With
'process the previous slide -
'this eliminates all the stuff with deciding how many sentences there are etc, because we are
'simply replacing the previous slide's range with new text

    If rSlide.Start > 0 Then 'check start >0 so we don't try to process anything before slide 1
    
    'work where possible with a string variable rather than a document range. MUCH faster
    sText = rSlide.Text
    
    'cut the number line
    iPos = InStr(sText, ":" & Chr(13))
    sText = Mid(sText, iPos + 1)
    
    'remove unwanted carriage returns
    While InStr(sText, Chr(13) & Chr(13))
    sText = Replace(sText, Chr(13) & Chr(13), Chr(13))
    Wend
    
    'cut any final CR
    If Right(sText, 1) = Chr(13) Then sText = Left(sText, Len(sText) - 1)
    
    'add marker code at each text line break
    sText = Replace(sText, Chr(13), Chr(11) & marker_code & "  ")
    
    'assemble full text, including existing sText
    sText = vSlide & " : " & staticTC & Chr(11) & static_next_line & Chr(11) & marker_code & " " & _
            vSlide & " : " & sText & Chr(13) & Chr(13)
            
            
    'replace the text in the pre-defined range for the slide. Much quicker than using the built-in find and replace
    rSlide.Text = sText
    End If

'set new start point for previous slide's range
rSlide.Start = rSlide.End + 1
'make vNext into vSlide
vSlide = vNext

'get current page
iPage = rSlide.Information(wdActiveEndAdjustedPageNumber)
'update status bar if new page
    If iPage > iPrev Then
    Application.StatusBar = "Processing page " & iPage
   'set new previous page
    iPrev = iPage
    'process "events" queue to force statusbar update
    DoEvents
    End If
Loop Until bStop
allOn
'exit routine if all ok

MsgBox "All pages processed in " & Format(Timer - uTime, "0.00") & " seconds."
Exit Sub
'handle error if not ok
errortrap:
allOn
MsgBox ("An error has occurred on page " & iPage)
End Sub

Open in new window

Author

Commented:
A few notes:  unrelated to this question directly however allon and alloff tells me that it's calling a sub that doesn't exist.  I'm using Word 2016 for Mac so perhaps the limitation is running it on a Mac.  I know that the vba toolset isn't as full as on the windows side.  

The progress bar works well however I suppose it's a bit confusing.  I was thinking about putting the total number of pages in the document so it says page x of total however it appears that a 50 page document turns into about 90 when using this macro so at some point, the total number of pages would be inaccurate?  Or would it dynamically update?

Also, would doing a simple copy and paste at the head of the program out of a table take care of the speed issue?
Neil FlemingConsultant and developer

Commented:
Did you put the code for allOn and AllOff in the module. They are not built-in routines... Should work fine on a Mac.

The page count updates as the document expands. Not sure what you mean by a simply copy and paste. There is a Word command in the table menu to "convert table to text". But if all the text is just in one table cell then yes, you could just copy and past it.

Sub allOff()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
End Sub

Sub allOn()
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.ScreenRefresh
End Sub

Open in new window

Author

Commented:
This has all, once again, been quite helpful.  I'll play with the convert table to text command as there's no real reason it is in a table, just how it gets delivered.  I'll keep this open for another day or two in case I have any questions.

Author

Commented:
I added:

tpage = rSlide.Information(wdNumberOfPagesInDocument)

and it increased the processing time by almost a minute.  Is that a expected?
Neil FlemingConsultant and developer

Commented:
yes it is probably slow. I suspect Word initiates a page count when you request that information. Its handling of page numbers in general is quite clunky, since it is figuring out on the fly what page everything is on.

You'll often see an incorrrect page count at the bottom of a Word document which only updates when you move to a new page, or save the document. My guess would be that Word does not continuously track the page count, but recalculates it when asked.

It might be quicker to count all the slides first by running a "find" loop that simply counts instances of "^p^#^#^#^#" without doing any processing, and then have your updater reference "slide X of Y"

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial