Help with Progress Bar for VBA macro

[francozola25]

Hello

I currently have a VBA macro that is ran from word. What it does is takes the documents name, declares it as variable name WordFN, then searches opens an excel workbook, finds this WordFN, offsets to the right, declares this values as ExcelFN and opens it likes so "C:\forms\" & ExcelFN & ".Doc"
It updates a field known as title on this and then prints off the word document. If it finds more than one value when offsetting, then it will create a list ExFnList and print these off.

What i want to do however is implement a progress bar. I have found one from this page http://j-walk.com/ss/excel/tips/tip34.htm but i am having problems where to locate it in the macro. I have tried with screenupdating=false but it works only till after finding ExcelFN. It will show the steps going through opening up the word documents and updating the fields. I do not want to show this but to have a progress bar instead.

Please see code below from francozola25

[francozola25]

I want looking to put it in as soon as the ExcelFN file is open up until in With UserForm2 will appear.


If ExcelFN <> "" Then
ExFnList = ExFnList & ExcelFN & "|"
'Declare new doc as bDoc and Open the following path(s) C:\forms\" & ExcelFN & ".Doc"
Set bDoc = Documents.Open("C:\forms\" & ExcelFN & ".Doc")
'Set Title of aDoc = bDoc
bDoc.BuiltInDocumentProperties("Title") = _
aDoc.BuiltInDocumentProperties("Title")
'Update the Title Fields by calling the UpdateStoryRanges procedure
Call UpdateStoryRanges(bDoc)
'Print off the Document(s) opened
bDoc.PrintOut
'Close Document(s) without saving changes
bDoc.Close savechanges:=wdDoNotSaveChanges
End If
'Loop Until 8 times, Column A = WordFN, Column B, C, D, E, F, G, H, I = ExcelFN
Loop Until aCol = 15
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress

[fumei]

Love to possibly help, but as the code window is GIGANTIC - as underscore character not used - I can not (will not) read your code.

PLEASE! PLEASE! PLEASE! Learn to use the underscore character. Really, it is not that hard, and it would be polite.

[francozola25]

Apologies for this, i have updated the code, hope this looks better

Thanks


Sub Update()
Dim Title As String
Dim frmTitle As UserForm1
Dim oStory As Range
'initialise the UserForm1
Set frmTitle = New UserForm1
'Display the Userfrom and declare Title as the TextFormField
With frmTitle
.Show
ActiveDocument.BuiltInDocumentProperties("Title").Value = .Title.Text
End With
Unload frmTitle
'Release object references.
Set frmTitle = Nothing
'Call Macro to update all values with Title of the FormField
Call UpdateStoryRanges(ActiveDocument)
'Call Macro SheetPrintOut
Call SheetPrintOut
End Sub
Sub SheetPrintOut()
'Takes Document Name as WordFN
'Open the following workbook C:\forms\index.xls
'Conduct a search in Column, offset and declare this value as ExcelFN
'Open the following Word Doc path "C:\forms\" & ExcelFN & ".Doc"
'Call UpdateStoryRanges(bDoc) to update the FormField named Title

Dim aDoc As Document
Dim bDoc As Document
Dim oXL2 As Excel.Application
Dim oXL As Excel.Application
Dim oWB As Excel.Workbook
Dim oWB2 As Excel.Workbook
Dim oDoc As Word.Application
Dim oSheet As Excel.Worksheet
Dim c As Excel.Range
Dim FirstAddress As String
Dim ExcelWasNotRunning As Boolean
Dim WorkbookToWorkOn As String
Dim WordFN As String
Dim ExcelFN As String
Dim ProductFN As String
Dim LocationFN As String
Dim aCol As Integer
Dim ExFnList As String

'When the macro runs, do not the macro going through the steps on screen
Application.ScreenUpdating = False

Set aDoc = ActiveDocument
'Word document name open (aDoc) is declared as WordFn
WordFN = Left(aDoc.Name, Len(aDoc.Name) - 4)
'Open index.xls from the following path
WorkbookToWorkOn = "C:\index.xls"
'If Excel is running, get a handle on it; otherwise start a new instance of Excel
On Error Resume Next
Set oXL = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
ExcelWasNotRunning = True
Set oXL = New Excel.Application
oXL.ScreenUpdating = False
End If
On Error GoTo Err_Handler
'Open the workbook WorkbookToWorkOn LineClearance.xls
Set oWB = oXL.Workbooks.Open(FileName:=WorkbookToWorkOn)
'Initialise Sheet1
Set oSheet = oWB.Worksheets(1)
'Find last cell with data in column A and set it for the range
RowI = oSheet.Cells(oSheet.Rows.Count, "C").End(xlUp).Row
With oSheet.Range("c1:c" & RowI)
'Find the variable WordFN within the Range in column A
Set c = .Find(WordFN, LookIn:=xlValues)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
Do
ProductFN = c.Offset(0, -1).Value
LocationFN = c.Offset(0, -2).Value
'create a loop for Offsetting to the next
aCol = aCol + 1
'Declare ExcelFN as the Offsetted Value
ExcelFN = c.Offset(0, aCol).Value
'If there are more than one value Offset then create a List
If ExcelFN <> "" Then
ExFnList = ExFnList & ExcelFN & "|"
'Declare new doc as bDoc and Open the following path(s) C:\forms\" & ExcelFN & ".Doc"
Set bDoc = Documents.Open("C:\forms\" & ExcelFN & ".Doc")
'Set Title of aDoc = bDoc
bDoc.BuiltInDocumentProperties("Title") = _
aDoc.BuiltInDocumentProperties("Title")
'Update the Title Fields by calling the UpdateStoryRanges procedure
Call UpdateStoryRanges(bDoc)
'Print off the Document(s) opened
bDoc.PrintOut
'Close Document(s) without saving changes
bDoc.Close savechanges:=wdDoNotSaveChanges
End If
'Loop Until 8 times, Column A = WordFN, Column B, C, D, E, F, G, H, I = ExcelFN
Loop Until aCol = 15
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
'Display a Userform2 Stating the (Document Name) along with the ExFnList of Forms
With UserForm2
.TextBox1 = Chr(10) & "Product Name: " & ProductFN & Chr(10) & "Reference Number: " _
& WordFN & Chr(10) & Chr(10) & Chr(10) & "The following forms attached are attached: " _
& Chr(10) & Chr(10) & Replace(ExFnList, "|", Chr(10)) & Chr(10) & "Forms for " _
& WordFN & " have been sent to the printer..."
.Show
End With
Else
'If a (Document Name) cannot be found in Excel range then the following message is produced
MsgBox ("REF " + WordFN + " does not contain additional Forms")
End If
End With
If ExcelWasNotRunning Then
oXL.Quit
Else
oWB.Close
End If
'Make sure you release object references.
Set oRng = Nothing
Set oSheet = Nothing
Set oWB = Nothing
Set oXL = Nothing
'quit
Exit Sub
Err_Handler:
'Error Message stating that the Excel Workbook cannot be found
MsgBox WorkbookToWorkOn & " could not be accessed at this time. " & " _
This may be occur if you are not connected to the Network _
Please Contact your IT Department immediately"
If ExcelWasNotRunning Then
oXL.Quit
End If
Set oRng = Nothing
Set oSheet = Nothing
Set oWB = Nothing
Set oXL = Nothing
End Sub
Sub UpdateStoryRanges(CurrentDoc As Document)
'Loop to update the main body of the document
For Each oStory In CurrentDoc.StoryRanges
'Update the all the FormFields
oStory.Fields.Update
If oStory.StoryType < wdMainTextStory Then
'Loop through main body of document until all fields are updated
While Not (oStory.NextStoryRange Is Nothing)
Set oStory = oStory.NextStoryRange
oStory.Fields.Update
Wend
End If
Next oStory
Set oStory = Nothing
End Sub

[fumei]

No...you need to go back and edit your FIRST one as well.

BTW: I think you made a record with your post. I have never seen such a wide one. Here is what it looks like on my monitor. Notice the bottom scroll bar!!!!!

[Tinbendr]

See attachment for sample.

The userform starts it off, then the userform calls the main program.

While I like the feedback of progress bars, they are too much trouble for me.

I prefer to us the Status Bar at the bottom left.

So, instead of all the bar code, just put Application.StatusBar = ACol just above the Loop Until.

[francozola25]

I just think the Userform containing the Progress bar would far better than a message in the status bar. If i have to open and print off say 8 docs, i want the user to be able to view the progress of the docs being printed. Could i ask where abouts could i integrate this progress bar userform into the SheetPrintOut code?

[Tinbendr]

Sorry, I should have been a little more diligent.

To the SheetPrintOut(), add at the top:Dim ACol As Integer
Dim Max As Integer
Dim PctDone As Double
'You don't have to use a variable
'for the max loop count, but it makes
'it easier to change in just one place
'if more forms get added.
Max = 15
Then bDoc.Close savechanges:=wdDoNotSaveChanges
End If
PctDone = ACol / Max
With ufProgressBar
.FrameProgress.Caption = Format(PctDone, "0%")
.LabelProgress.Width = PctDone * (.FrameProgress.Width - 10)
End With
'The DoEvents statement is responsible for the form updating
DoEvents
'Loop Until 8 times, Column A = WordFN,
'Column B, C, D, E, F, G, H, I = ExcelFN
Loop Until ACol = Max
Beep
Unload ufProgressBar
End Sub

Open my example and your document. Enter the VBE and drag the userform (from the left side) from my example to yours.

Make sure you change the Call Main in the userform.activate to Call SheetPrintOut.

[francozola25]

Just a quick back on that, i had put that code, but was getting an error about no Do with Until Loop. So i modifed the code, ACol is for when i am offsetting in Excel while BCol is for the Progress Bar. I am getting no error now but it does not bring up the userform. I have modified the code a little, and i have changed userform.activate to Call SheetPrintOut. Please see..


Do
ProductFN = c.Offset(0, -1).Value
'create a loop for Offsetting to the next
ACol = ACol + 1
'Declare ExcelFN as the Offsetted Value
ExcelFN = c.Offset(0, ACol).Value
'If there are more than one value Offset then create a List
If ExcelFN <> "" Then
ExFnList = ExFnList & ExcelFN & "|"
'Declare new bDoc and Open C:\forms\" & ExcelFN & ".Doc"
Set bDoc = Documents.Open("C:\forms\" & ExcelFN & ".Doc")
'Set Title of aDoc = bDoc
bDoc.BuiltInDocumentProperties("Title") = _
aDoc.BuiltInDocumentProperties("Title")
'Update the Title Fields by calling the UpdateStoryRanges
Call UpdateStoryRanges(bDoc)
'Print off the Document(s) opened
bDoc.PrintOut
'Close Document(s) without saving changes
bDoc.Close savechanges:=wdDoNotSaveChanges
End If
With ufProgressBar
.FrameProgress.Caption = Format(PctDone, "0%")
.LabelProgress.Width = PctDone * (.FrameProgress.Width - 10)
End With
DoEvents
'Loop Until 8 times
Loop Until ACol = 8 & BCol = Max
Set c = .FindNext(c)
Beep
Unload ufProgressBar
Loop While Not c Is Nothing And c.Address <> FirstAddress
PctDone = BCol / Max

'DoEvents
'Loop Until BCol = Max
'Beep
'Unload ufProgressBar
With UserForm2
.TextBox1 = "Error"
.Show
End With
Else
'If a Doc (Name) cannot be found in Excel range then the following message is produced
MsgBox ("Doc " + WordFN + " cannot be found")
End If
End With

[francozola25]

Just a quick back on that, i had put that code, but was getting an error about no Do with Until Loop. So i modifed the code, ACol is for when i am offsetting in Excel while BCol is for the Progress Bar. I am getting no error now but it does not bring up the userform. I have modified the code a little, and i have changed userform.activate to Call SheetPrintOut. Please see..


Do
ProductFN = c.Offset(0, -1).Value
'create a loop for Offsetting to the next
ACol = ACol + 1
'Declare ExcelFN as the Offsetted Value
ExcelFN = c.Offset(0, ACol).Value
'If there are more than one value Offset then create a List
If ExcelFN <> "" Then
ExFnList = ExFnList & ExcelFN & "|"
'Declare new bDoc and Open C:\forms\" & ExcelFN & ".Doc"
Set bDoc = Documents.Open("C:\forms\" & ExcelFN & ".Doc")
'Set Title of aDoc = bDoc
bDoc.BuiltInDocumentProperties("Title") = _
aDoc.BuiltInDocumentProperties("Title")
'Update the Title Fields by calling the UpdateStoryRanges
Call UpdateStoryRanges(bDoc)
'Print off the Document(s) opened
bDoc.PrintOut
'Close Document(s) without saving changes
bDoc.Close savechanges:=wdDoNotSaveChanges
End If
With ufProgressBar
.FrameProgress.Caption = Format(PctDone, "0%")
.LabelProgress.Width = PctDone * (.FrameProgress.Width - 10)
End With
DoEvents
'Loop Until 8 times
Loop Until ACol = 8 & BCol = Max
Set c = .FindNext(c)
Beep
Unload ufProgressBar
Loop While Not c Is Nothing And c.Address <> FirstAddress
PctDone = BCol / Max

'DoEvents
'Loop Until BCol = Max
'Beep
'Unload ufProgressBar
With UserForm2
.TextBox1 = "Error"
.Show
End With
Else
'If a Doc (Name) cannot be found in Excel range then the following message is produced
MsgBox ("Doc " + WordFN + " cannot be found")
End If
End With

[Tinbendr]

ACol is for when i am offsetting in Excel while BCol is for the Progress Bar. But ACol is what you are measuring. BCol doesn't refer to anything in your snippet.


Loop Until ACol = 8 & BCol = Max

You can't do this either. It will be a endless loop. It needs to be Loop Until ACol = 8
'or
Loop Until ACol = Max

The reason I've implemented the Max variable is to make future changes easier. If you add a form later on, then you only have to change the macro in one place, (Max = 9) instead of hunting for the Loop Until and the denominator for the ProgressBar calculation.


...no error now but it does not bring up the userform.
Are you calling the userform first?

To recap: You start the macro with this sub.

Sub StartUp()
Load ufProgressBar
ufProgressBar.LabelProgress.Width = 0
ufProgressBar.Show
End Sub

When you 'show' the userform, the Activate calls the SheetPrintout Sub. During that sub, the progress bar gets updated. So while ACol is being incremented, we use that value to calculate the percentage of completion and apply that to the progresslabel.

If you can't get it working, post the SheetPrintOut code prior to adding the Progressbar and I'll try to get it setup for you. (But it might be Monday before I get a chance to work on it. I'm preparing to go out of town.)

David

[francozola25]

No worries David,

This progress bar is the second userform i will use.

My first form will appear at the beginning asking me to input title, once done, i will take the docs name as FNWord

Then excel will do search for this FNWord in column C, and offset to the right to the ExcelFNlist.

I will then open whatever is in ExcelFNlist, i want the progress bar to appear here as it is opening the doc, updating the fields for each doc.

My third form will appear next stating what userforms have been printed off.

Have a great trip out of town!

[francozola25]

Please see current code

-Userform1 is called at Update macro for inputting the number.
-ufProgressBar i want to call for instead of showing all the word docs opened for "C:\forms\" & ExcelFN & ".Doc" and printed off, i want to have the progress bar appear here instead
-Userform2 displays the results of for WordFN anfd what forms were printed "C:\forms\" & ExcelFN & ".Doc"


Sub Update()
Dim Title As String
Dim frmTitle As UserForm1
Dim oStory As Range
'initialise the UserForm1
Set frmTitle = New UserForm1
'Display the Userfrom and declare Title as the TextFormField
With frmTitle
.Show
ActiveDocument.BuiltInDocumentProperties("Title").Value = .Title.Text
End With
Unload frmTitle
'Release object references.
Set frmTitle = Nothing
'Call Macro to update all values with Title of the FormField
Call UpdateStoryRanges(ActiveDocument)
'Call Macro SheetPrintOut
Call SheetPrintOut
End Sub

Sub SheetPrintOut()
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
'Takes Document Name as WordFN
'Open the following workbook C:\forms\index.xls
'Conduct a search in Column, offset and declare this value as ExcelFN
'Open the following Word Doc path "C:\forms\" & ExcelFN & ".Doc"
'Call UpdateStoryRanges(bDoc) to update the FormField named Title

Dim aDoc As Document
Dim bDoc As Document
Dim oXL2 As Excel.Application
Dim oXL As Excel.Application
Dim oWB As Excel.Workbook
Dim oWB2 As Excel.Workbook
Dim oDoc As Word.Application
Dim oSheet As Excel.Worksheet
Dim c As Excel.Range
Dim FirstAddress As String
Dim ExcelWasNotRunning As Boolean
Dim WorkbookToWorkOn As String
Dim WordFN As String
Dim ExcelFN As String
Dim ProductFN As String
Dim LocationFN As String
Dim ACol As Integer
Dim ExFnList As String
Dim myOutlook As Object
Dim myMailItem As Object
Dim Max As Integer
Dim PctDone As Double

Max = 15

Set aDoc = ActiveDocument
'Word document name open (aDoc) is declared as WordFn
WordFN = Left(aDoc.Name, Len(aDoc.Name) - 4)
WorkbookToWorkOn = "C:\forms\index.xls"
'If Excel is running, get a handle on it; otherwise start a new instance of Excel
On Error Resume Next
Set oXL = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
ExcelWasNotRunning = True
Set oXL = New Excel.Application
oXL.ScreenUpdating = False
End If
On Error GoTo Err_Handler
Set oWB = oXL.Workbooks.Open(FileName:=WorkbookToWorkOn)
'Initialise Sheet1
Set oSheet = oWB.Worksheets(1)
'Find last cell with data in column A and set it for the range
RowI = oSheet.Cells(oSheet.Rows.Count, "C").End(xlUp).Row
With oSheet.Range("c1:c" & RowI)
'Find the variable WordFN within the Range in column A
Set c = .Find(WordFN, LookIn:=xlValues)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
Do
ProductFN = c.Offset(0, -1).Value
LocationFN = c.Offset(0, -2).Value
Set myOutlook = CreateObject("Outlook.Application")
Set myMailItem = myOutlook.createitem(0)
'create a loop for Offsetting to the next
ACol = ACol + 1
'Declare ExcelFN as the Offsetted Value
ExcelFN = c.Offset(0, ACol).Value
'If there are more than one value Offset then create a List
If ExcelFN <> "" Then
ExFnList = ExFnList & ExcelFN & "|"
'Declare bDoc and Open path(s) C:\forms\" & ExcelFN & ".Doc"
Set bDoc = Documents.Open("C:\forms\" & ExcelFN & ".Doc")
'Set Title of aDoc = bDoc
bDoc.BuiltInDocumentProperties("Title") = _
aDoc.BuiltInDocumentProperties("Title")
'Update the Title Fields by calling the UpdateStoryRanges procedure
Call UpdateStoryRanges(bDoc)
'Print off the Document(s) opened
bDoc.PrintOut
'Close Document(s) without saving changes
bDoc.Close savechanges:=wdDoNotSaveChanges
End If
PctDone = ACol / Max
With ufProgressBar
.FrameProgress.Caption = Format(PctDone, "0%")
.LabelProgress.Width = PctDone * (.FrameProgress.Width - 10)
End With
DoEvents
'Loop Until 15 times, Column A = WordFN,
Loop Until ACol = Max
Beep
Unload ufProgressBar
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
With UserForm2
.TextBox1 = Chr(10) & "Product Name: " & ProductFN & Chr(10) & _
"Reference Number: " & WordFN & Chr(10) & _
"Forms attached: " & Chr(10) & Replace(ExFnList, "|", Chr(10)) & Chr(10)
.Show
If LocationFN = "Engineering" Then
myMailItem.Recipients.Add "joe.bloggs@engineeringemailaddress.com"
myMailItem.Subject = "Processing " & "Doc " & WordFN & " : " & ProductFN & "is being completed"
myMailItem.body = "Doc " & WordFN & " for Product " & ProductFN & "is currently being processed"
myMailItem.send
Set myOutlook = Nothing
ElseIf LocationFN = "Finance" Then
myMailItem.Recipients.Add "joe.bloggs@financeemailaddress.com"
myMailItem.Subject = "Processing " & "Doc " & WordFN & " : " & ProductFN & "is being completed"
myMailItem.body = "Doc " & WordFN & " for Product " & ProductFN & "is currently being processed"
myMailItem.send
Set myOutlook = Nothing
Else
MsgBox ("Email alert cannot be sent as an Area not been specified")
End If
End With
Else
'If Document Name cannot be found in Excel range then the following message is produced
MsgBox ("Doc " + WordFN + " cannot be found. Forms will have to be manually inserted and printed")
End If
End With
If ExcelWasNotRunning Then
oXL.Quit
Else
oWB.Close
End If
'Make sure you release object references.
Set oRng = Nothing
Set oSheet = Nothing
Set oWB = Nothing
Set oXL = Nothing
'quit
Exit Sub
Err_Handler:
'Error Message stating that the Excel Workbook cannot be found
MsgBox WorkbookToWorkOn & " could not be accessed at this time. "
If ExcelWasNotRunning Then
oXL.Quit
End If
Set oRng = Nothing
Set oSheet = Nothing
Set oWB = Nothing
Set oXL = Nothing

End Sub

Sub UpdateStoryRanges(CurrentDoc As Document)
'Loop to update the main body of the document
For Each oStory In CurrentDoc.StoryRanges
'Update the all the FormFields
oStory.Fields.Update
If oStory.StoryType < wdMainTextStory Then
'Loop through main body of document until all fields are updated
While Not (oStory.NextStoryRange Is Nothing)
Set oStory = oStory.NextStoryRange
oStory.Fields.Update
Wend
End If
Next oStory
Set oStory = Nothing
End Sub

[Tinbendr]

I think just Sub Update()...
'Call SheetPrintOut
ufProgressBar.ShowShould get it working.

[francozola25]

Thanks Tinbendr

The only problem is when it is called at the beginning, it has a full completed bar, is there a way to change this that i can change start to 0%?

Also when it updates, it opens the word doc and then shows word is updating the fields of the document, then cuts back to the progress bar with the percentage, then agains shows the opening of the word file and the updating of the fields of the document etc.

Is there a way to have just the progress bar, so that you have

UserForm1 is the input form then then ufProgressBar showing the macro processing with UserForm2 with the results.

[francozola25]

Tinbendr

Thanks for that

I set ufProgressBar.LabelProgress.Width = 0 at the beginning of the SheetPrintOut and it has worked at initialising the Progress Bar to 0

The only problem is that when the progress bar is running it is skipping in and out of the documents being opened and updated. I have tried adding Visible:=True in the following code but it still doesn't work


Set bDoc = Documents.Open("C:\forms\" & ExcelFN & ".Doc", ReadOnly:=True, Visible:=True)

[francozola25]

Apologies Tinbendr

I have set Visible:=False and it is working perfect, brillant thanks again!