Add Progress Bar to Existing Code
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?
Code:
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
