I'm trying to put together a 'Status Bar Progress Meter' to help the user when loading a lengthy macro.
I've carried out some research and found this to be the type that I'd like to use.
The problem I have is that the progress bar doesn't move across the Status Bar and the first and last messages i.e. "Working" and "All Files Extracted" are not shown. Where have I gone wrong?
Private Sub btnFetchFiles_Click()
Dim j As Integer
iRow = 20
fPath = "\\c\s\CAF1\Dragon Mentor Group\Dragon Scripts\Current\April 2015"
If fPath <> "" Then
' make StatusBar visible
Application.DisplayStatusBar = True
Set FSO = New Scripting.FileSystemObject
'First Message
Application.StatusBar = String(5, ChrW(9609)) & " Working..."
If FSO.FolderExists(fPath) <> False Then
'Second Message
Application.StatusBar = String(5, ChrW(9609)) & " Working..."
Set SourceFolder = FSO.GetFolder(fPath)
'Third Message
Application.StatusBar = String(5, ChrW(9609)) & " Working..."
IsSubFolder = True
'Fourth Message
Application.StatusBar = String(5, ChrW(9609)) & " Still Working..."
Call DeleteRows
If AllFilesCheckBox.Value = True Then
'Fifth Message
Application.StatusBar = String(5, ChrW(9609)) & " Still Working..."
Call ListFilesInFolder(SourceFolder, IsSubFolder)
Call ResultSorting(xlAscending, "C20")
Call FormatCells
Else
Call ListFilesInFolderXtn(SourceFolder, IsSubFolder)
Call ResultSorting(xlAscending, "C20")
Call FormatCells
End If
'Sixth Message
Application.StatusBar = String(5, ChrW(9609)) & "Still Working..."
lblFCount.Caption = iRow - 20
'Seventh Message
Application.StatusBar = String(5, ChrW(9609)) & "Almost Done..."
Else
MsgBox "Selected Path Does Not Exist !!" & vbNewLine & vbNewLine & "Select Correct One and Try Again !!"
End If
Else
MsgBox "Folder Path Can not be Empty !!" & vbNewLine & vbNewLine & ""
End If
'Eigth Message
Application.StatusBar = String(5, ChrW(9609)) & "All Files Extracted..."
'Relinquish the StatusBar
Application.StatusBar = False
End Sub