So I got some code off the internet that looks at an outlook folder (chosen by user) and returns each email's date stamp, sender name and subject.
When I run the code it hangs at around 48% for like ever. Only time it finished before I interfered was when I came back from a 15 min break.
However, after 5 minutes or so of it being hung up at around 48% if I hit ESC and end the module, all of the email data for each email is present in my spreadsheet.
Any idea why it is hanging up and how I can fix it? I would like this to be a bit more efficient.
Thanks
Rich
When I run the code it hangs at around 48% for like ever. Only time it finished before I interfered was when I came back from a 15 min break.
However, after 5 minutes or so of it being hung up at around 48% if I hit ESC and end the module, all of the email data for each email is present in my spreadsheet.
Any idea why it is hanging up and how I can fix it? I would like this to be a bit more efficient.
Code:
Option Explicit
Public gblStopProcessing As Boolean
Sub ParseBlockingSessionsEmailPartOne()
' This macro requires Microsoft Outlook Object Library (Menu: Tools/References) be available
Dim wb As Workbook
Dim ws As Worksheet
Dim objFolder As Object
Dim objNSpace As Object
Dim objOutlook As Outlook.Application
Dim lngAuditRecord As Long
Dim lngCount As Long
Dim lngTotalItems As Long 'Count of emails in the Outlook folder.
Dim lngTotalRecords As Long
Dim i As Integer
Dim EmailCount As Integer 'The counter, which starts at zero.
'
On Error GoTo HandleError
' Initialize:
Set wb = ThisWorkbook
lngAuditRecord = 1 ' Start row
lngTotalRecords = 0
Set ws = Sheets("GC email count")
'===============================================================================
'READ EMAIL MESSAGES PROCESS
'===============================================================================
Application.ScreenUpdating = False
Set objOutlook = CreateObject("Outlook.Application")
Set objNSpace = objOutlook.GetNamespace("MAPI")
'===============================================================================
'ALLOW USERS TO PICK THE EMAIL FOLDER PROCESS
'===============================================================================
Set objFolder = objNSpace.PickFolder
'===============================================================================
'CHECK TO SEE IF USER CANCELLED THE FOLDER PICK PROCESS
'===============================================================================
If objFolder Is Nothing Then
gblStopProcessing = True
MsgBox "Processing cancelled"
Exit Sub
End If
'===============================================================================
'COUNT THE EMAILS IN THE CHOSEN FOLDER
'===============================================================================
lngTotalItems = objFolder.Items.Count
'===============================================================================
'IF STATEMENT 'IF COUNT = 0
'===============================================================================
If lngTotalItems = 0 Then
MsgBox "Outlook folder contains no email messages", vbOKOnly + vbCritical, "Error - Empty Folder"
gblStopProcessing = True
GoTo HandleExit
End If
'===============================================================================
'IF STATEMENT 'IF COUNT IS MORE THAN 0
'===============================================================================
If lngTotalItems > 0 Then
On Error Resume Next
'Insert Title Row and Format NOTE: THE MACRO CAN BE USED TO PARSE OUT OTHER PARTS OF AN EMAIL.
' I JUST COMMENTED OUT THE LINES NOT USED FOR THE CURRENT PROJECT.
ws.Cells(1, 2) = "Received"
'ws.Cells(1, 2) = "Email Body"
ws.Cells(lngAuditRecord, 4) = "Subject"
'ws.Cells(lngAuditRecord, 4) = "Attachments Count"
ws.Cells(lngAuditRecord, 3) = "Sender Name"
'ws.Cells(lngAuditRecord, 5) = "Sender Email"
ws.Range("A1").Select
With Selection
.EntireRow.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
'Populate the workbook
For lngCount = 1 To lngTotalItems
Application.StatusBar = "Reading message " & lngCount & " of " & lngTotalItems
i = 0
'read email info
While i < lngTotalItems
i = i + 1
If i Mod 50 = 0 Then Application.StatusBar = "Reading email messages " & Format(i / lngTotalItems, "0%") & "..."
With objFolder.Items(i)
Cells(i + 1, 2).Formula = .ReceivedTime
'Cells(i + 1, 2).Formula = .Body
Cells(i + 1, 4).Formula = .Subject
'Cells(i + 1, 4).Formula = .Attachments.Count
Cells(i + 1, 3).Formula = .SenderName
'Cells(i + 1, 6).Formula = .SenderEmailAddress
End With
Wend
'Set objFolder = Nothing
ws.Activate
Next lngCount
lngTotalRecords = lngCount
Dim lrow As Integer
With ws
lrow = Range("B" & Rows.Count).End(xlUp).Row
Range("A1").Value = "Email count"
Range("A2") = 1
Range("A2").Select
Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
Step:=1, Stop:=lrow, Trend:=False
End With
'Format Worksheet
Dim rng As Range
Set rng = Range("A").UsedRange
rng.Select
Columns.AutoFit
Rows.AutoFit
End If
' Check that records have been found:
If lngTotalRecords = 0 Then
MsgBox "No records were found for import", vbOKOnly + vbCritical, "Error - no records found"
gblStopProcessing = True
GoTo HandleExit
End If
HandleExit:
On Error Resume Next
Application.ScreenUpdating = True
Set objNSpace = Nothing
Set objFolder = Nothing
Set objOutlook = Nothing
Set ws = Nothing
Set wb = Nothing
If Not gblStopProcessing Then
MsgBox "Processing completed" & vbCrLf & vbCrLf & _
"Please check results", vbOKOnly + vbInformation, "Information"
End If
Exit Sub
HandleError:
MsgBox Err.Number & vbCrLf & Err.Description
gblStopProcessing = True
Resume HandleExit
End SubThanks
Rich
