Add Progress Bar to Existing Code

[danny8890]

Hey,

I've got a piece of code that copies all selected emails from Outlook into a specific Excel Document, all working fine.

I've been trying for sometime now to add a progress bar to this so i can see where it's up to as this can sometimes take in excess of 30 minutes to complete and outlook just sits as if it's crashed (it hasn't), If anyone would be kind enough to help would be much appreciated.

Option ExplicitSub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim strPath As String


Dim currentExplorer As Explorer
Dim Selection As Selection
Dim olItem As Outlook.MailItem
Dim obj As Object
Dim strColA, strColB, strColC, strColD, strColE, strColF As Date
               
' Get Excel set up


'the path of the workbook
strPath = "\\P:\Implementation\UTA\UTA - Raw.xlsm"
     On Error Resume Next
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
         Application.StatusBar = "Please wait while Excel source is opened ... "
         Set xlApp = CreateObject("Excel.Application")
         bXStarted = True
     End If
     On Error GoTo 0
     'Open the workbook to input the data
     Set xlWB = xlApp.Workbooks.Open(strPath)
     Set xlSheet = xlWB.Sheets("Sheet1")
    ' Process the message record
    
    On Error Resume Next
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1


' get the values from outlook
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
  For Each obj In Selection


    Set olItem = obj
    
 'collect the fields
    strColC = olItem.SenderEmailAddress
    strColA = olItem.Subject
    strColB = olItem.Sender
    strColD = olItem.Body
    strColE = olItem.To
    strColF = olItem.ReceivedTime
    


'write them in the excel sheet
  xlSheet.Range("A" & rCount) = strColA
  xlSheet.Range("B" & rCount) = strColB
  xlSheet.Range("c" & rCount) = strColC
  xlSheet.Range("d" & rCount) = strColD
  xlSheet.Range("e" & rCount) = strColE
  xlSheet.Range("f" & rCount) = strColF
  
'Next row
  rCount = rCount + 1


Next


  With xlWB.Sheets(1)
    .Range("A:F").WrapText = False
    
End With


     xlWB.Close 1
     If bXStarted Then
         xlApp.Quit
     End If
    
     Set olItem = Nothing
     Set obj = Nothing
     Set currentExplorer = Nothing
     Set xlApp = Nothing
     Set xlWB = Nothing
     Set xlSheet = Nothing
     
     
' Show summary message
        MsgBox "Finished" _
    


    
 End Sub

 

[dmt32]

Hi,
not able to test your code by try following:

Place following code in a STANDARD module

Sub ShowProgressBar(ByVal ProgressCount As Long, ByVal MaxCount As Long, Step As Long, _
                    Optional ByVal Width As Long = 100, Optional ByVal DisplayText As Variant)


  Dim Steps As Long


  If Width = 0 Then Width = 100
  
  If IsMissing(DisplayText) Then DisplayText = "Record " & ProgressCount & " of " & MaxCount
  
  If ProgressCount Mod Step = 0 Or ProgressCount = MaxCount Then
    Steps = Round((ProgressCount / MaxCount) * Width, 0)
    DoEvents
    Application.StatusBar = String(Steps, "|") & _
                            String(Width - Steps, ".") & "| " & _
                            Format(ProgressCount / MaxCount, "Percent") & _
                             "    " & DisplayText
  End If


End Sub

Update the For Next Loop with lines shown in RED as follows:

For Each obj In Selection
    
    ShowProgressBar rCount, Selection.Count, 1
    
    Set olItem = obj
    
'collect the fields
    strColC = olItem.SenderEmailAddress
    strColA = olItem.Subject
    strColB = olItem.Sender
    strColD = olItem.Body
    strColE = olItem.To
    strColF = olItem.ReceivedTime
    
    
'write them in the excel sheet
    xlSheet.Range("A" & rCount) = strColA
    xlSheet.Range("B" & rCount) = strColB
    xlSheet.Range("c" & rCount) = strColC
    xlSheet.Range("d" & rCount) = strColD
    xlSheet.Range("e" & rCount) = strColE
    xlSheet.Range("f" & rCount) = strColF
    
'Next row
    rCount = rCount + 1
    
    Set olItem = Nothing
    
Next

As stated, solution is untested for your application but hopefully, may give you something to work with

Dave

 

[danny8890]

Hi, thanks for your reply, I did what you suggested above, added the first part into a new standard module and then added the 2 lines of code, when i run the macro it just did what it did before and didn't show any progress bar

 

[danny8890]

Just to note, this is being added into Outlook not excel

 

[dmt32]

Hi, thanks for your reply, I did what you suggested above, added the first part into a new standard module and then added the 2 lines of code, when i run the macro it just did what it did before and didn't show any progress bar

If the statusbar is not visible then just before the For Next Loop add this line

Application.DisplayStatusBar = True

Dave

 

[dmt32]

Just to note, this is being added into Outlook not excel

which is why I said I was unable to test - solution was written for Excel but you may be able to adapt for your requirement.


Dave

 

[danny8890]

I've added the extra line of code still nothing showing, not getting any errors either

If the statusbar is not visible then just before the For Next Loop add this line

Application.DisplayStatusBar = True

Dave

 

[dmt32]

I've added the extra line of code still nothing showing, not getting any errors either

I should have done some reading before posting:

Changing the Status Bar

There is no way to change the status bar text in Microsoft Outlook. The status bar is not exposed as it is in other Microsoft Office object models.

so sorry, unless another here knows differently, it looks like my suggestion will not work. You could probably create a Userform to perform the operation but suggest you post in an Outlook forum for assistance..

Dave.

 

[danny8890]

Thanks for your help, I've just been looking and found a userform on a outlook forum. Thanks again

 

[Macropod]

Cross-posted at: http://www.vbaexpress.com/forum/showthread.php?63582-Add-Progress-Bar-to-Existing-Code
Please read Mr Excel's policy on Cross-Posting in rule 13: http://www.mrexcel.com/forum/board-announcements/99490-forum-rules.html