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 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

[macropod]

Cross-posted at: https://www.mrexcel.com/forum/genera...ting-code.html
Please read VBA Express' policy on Cross-Posting in item 3 of the rules: http://www.vbaexpress.com/forum/faq...._new_faq_item3

[danny8890]

Hi Apologies, didnt know both sites were linked you can see from MrExcel i was advised to use an outlook forum so i did. Please delete this post or delete on mr excel

Thanks

[macropod]

Neither VBA Express nor Mr Excel ordinarily deletes threads in such cases - and the sites are not linked. Please familiarise yourself with the rules of both forums.

[skatonni]

Full code for creating a progress bar may be beyond a forum. Try working it out with this as a resource http://www.outlookcode.com/codedetail.aspx?id=1077 or other resources you found. If you cannot, you could ask a more specific question about your attempt.