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.

I've read that progress bar will slow down this too, is anyone able to make the code run faster so doesn't take as long?

Option Explicit

Sub 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