# Retrieving mail attachments given criteria with VBA

Scenario: I (together with great help from SO) finished this piece of code which downloads attachments from an e-mail account (outlook) with VBA.

Issue: Given the internal functioning of the code, and the sheer amount of e-mails to check (more than 800k) the code cannot function in available time. Last time I tried to run it, it went on for 8 days and then just stopped.

Question: Does anyone have any ideas on how to improve the efficiency of this code?

Obs: The code goes through a secondary e-mail account specified (first criteria), loops through the emails if they are from a certain sender (second criteria), opens file ad check if there are worksheets names "alpha" and "beta" (very smart idea given to me in SO, to find the third criteria), and if it does, saves the file in a final location.

Code:

Sub Get_Mail_Attachments()

Application.ScreenUpdating = False

Dim olApp As New Outlook.Application
Dim olNameSpace As Object
Dim olMailItem As Outlook.MailItem
Dim olFolder As Object
Dim olFolderName As String
Dim olAtt As Outlook.Attachments
Dim strName As String
Dim sPath As String
Dim i As Long
Dim j As Integer
Dim olSubject As String
Dim olSender As String
Dim sh As Worksheet
Dim LastRow As Integer

Dim TempFolder As String: TempFolder = VBA.Environ\$("TEMP")
Dim wB As Excel.Workbook

'delete content except from row 1
ThisWorkbook.Worksheets("FileNames").Rows(2 & ":" & ThisWorkbook.Worksheets("FileNames").Rows.count).Delete

'set foldername and subject
olFolderName = ThisWorkbook.Worksheets("Control").Range("D10")
olSender = ThisWorkbook.Worksheets("Control").Range("D16")

sPath = Application.FileDialog(msoFileDialogFolderPicker).Show
sPathstr = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)

Set olNameSpace = olApp.GetNamespace("MAPI")

'check if folder is subfolder or not and choose olFolder accordingly
Set olFolder = olNameSpace.Folders("email@email.com").Folders("Inbox")

If (olFolder = "") Then
Set olFolder = olNameSpace.Folders("email@email.com").Folders("Inbox")
End If

'loop through mails
h = 2
For i = 1 To olFolder.Items.count

'check to see if it is an e-mail
If olFolder.Items(i).Class <> olMail Then
Else
Set olMailItem = olFolder.Items(i)

'check if the search name is in the email subject
If (InStr(1, olMailItem.Sender, olSender, vbTextCompare) <> 0) Then

With olMailItem

For j = 1 To .Attachments.count

strName = .Attachments.Item(j).DisplayName

If Not Dir(sPathstr & "\" & strName) = vbNullString Then
strName = "(1)" & strName
Else
End If

'Save in temp
.Attachments(j).SaveAsFile TempFolder & "\" & strName
ThisWorkbook.Worksheets("FileNames").Range("A" & h) = strName

Set wB = Workbooks.Open(TempFolder & "\" & strName, True)
DoEvents

'Start error handling
On Error Resume Next
Set sh = wB.Sheets("alpha")
Set sh = wB.Sheets("beta")
If Err.Number <> 0 Then

'Error = At least one sheet is not detected
Else

'No error = both sheets found
.Attachments(j).SaveAsFile sPathstr & "\" & strName
End If
Err.Clear
Set sh = Nothing
wB.Close
On Error GoTo 0

h = h + 1

Next j

End With

End If

End If

Next i

Application.ScreenUpdating = True

End Sub

• Change If olFolder.Items(i).Class <> olMail Then : Else to If olFolder.Items(i).Class = olMail Then and get rid of the Else. I don't think it'll make you code much faster, but it will make it more readable. For readability, test for the condition you want, not the one you don't want. – FreeMan Jun 2 '17 at 11:08
• Same thing with If Err.Number <> 0 Then. Though I'd assume you want to create the "alpha" and "beta" worksheets if they don't exist and that code is missing? – FreeMan Jun 2 '17 at 11:13
• For a speed improvement, work with arrays, not the spreadsheet directly, and there are several other options to disable in Excel that can speed things up a bit. – FreeMan Jun 2 '17 at 11:15
• ^^ Just re-read and realized you're using the existence of "alpha" and "beta" as your flags to save the attachment. However you can still say If Err.Number = 0 Then, though, the way you've got it written, it's only testing for the existence of "beta". It will look for that whether "alpha" exists or not, which may not be what you're after. – FreeMan Jun 2 '17 at 11:33
• @FreeMan Thanks for the tips, I will try them. If the sheets do not exist, I just don't save that file to the final folder. I use the set to find them, if they don't exist, it is supposed to ignore that file (if it causes and error, it jumps to the next part). – DGMS89 Jun 2 '17 at 13:40

Some general review suggestions:

• Ditch the Hungarian Notation. Most people implement it incorrectly through no fault of their own.

• Add Option Explicit to the top of your code module. There are a couple of undefined variables in there.

• Use clear and meaningful variables names. What is h? After spending some time pondering the code, it appears to be the row number where you're writing information in your logging workbook, so call it something like logRowNum. That will make it pretty explicit to the next person (or you in 60 8 days.)

• You make reference to ThisWorkbook - it appears that you're expecting it to be your logging workbook, so Dim logWorkbook as Workbook and set it before opening any other workbooks. It appears that you don't have any issues with it for now but if you have an 8-day process running, someone could click on another workbook when it's open and ThisWorkbook now points at something else breaking your code.

• Indent your code neatly. Rubberduck (I'm a big fan and hang out in their chat room, but haven't yet started contributing) will help you with that. (It'll also help with renaming variables and a ton of other things.) Also, eliminating a lot of those extra blank lines will make it a bit more readable.

• Modify your If statements to test for what you're after instead of what you're not after. Having a blank True "statement" is very awkward to follow.

    'change:
If olFolder.Items(i).Class <> olMail Then
Else
'some code here
End If
'to:
If olFolder.Items(i).Class = olMail Then
'some code here
End If

• Eliminate empty Else clauses - they make me think you're going to write more code but haven't yet.

Specific to improving speed:

    strName = .Attachments.Item(j).DisplayName
If Instr(0, strName, "xls") > 0 then
'rest of the code here
End If
'loops to next email message

• Short-cut your worksheet check, as well as ensuring they both exist:

    Dim AlphaFound as Boolean
Dim BetaFound as Boolean
On Error Resume Next
Set sh = wB.Sheets("alpha")
If Err.Number = 0 Then    'alpha exists
AlphaFound = True
End If
If not AlphaFound Then
'only look for "is alpha" if "alpha" isn't there
Set sh = wB.Sheets("is alpha")
If Err.Number = 0 Then    'alpha exists
AlphaFound = True
End If
End If
If AlphaFound Then
Set sh = wB.Sheets("beta")
If Err.Number = 0 Then  'beta exists
BetaFound = True
End If
End If
'turn off error ignoring as soon as possible vvv
On error goto 0
If AlphaFound and BetaFound then
.Attachments(j).SaveAsFile sPathstr & "\" & strName
End If

• Ditch the Set wb = nothing. You're doing it 800,000 times and each time you do, Excel has to free the memory then reallocate it when you hit the next Set wb = something statement. Leave the object in memory until you're done processing. Actually, VBA will Set all objects to Nothing automatically at the end of the Sub for you, so there's no reason to do it for any of them. (Note that wb is the only object you're manually freeing.)

• Put the trailing \ on all paths as early as possible to minimize concatenation later. (Don't know how much execution time it will save, but it will save typing time.)

    sPath = Application.FileDialog(msoFileDialogFolderPicker).Show
If Right(sPath, 1) <> "\" then
sPath = sPath & "\"
End If

• You have a DoEvents in there, which is being a good Windows citizen, but you may have it a bit too frequently. Maybe move it to outside your attachment count loop so you only do it once per email. I hate to suggest another counter in there, but maybe one that counts processed emails - every time you process 10 emails with attachments, DoEvents and reset the counter. That way other things can still run on the machine, but you're not pausing your process too frequently. If this is running on a dedicated machine (for 8 days!) maybe make it every 100 messages... If the machine is dedicated to this process, you might get away with not having it in there at all.

• Thanks for the (very enlightening) answer. I will be sure to check all those tips. For the "DoEvents" part, which other function would you recommend as a counter? – DGMS89 Jun 7 '17 at 8:36
• Not really sure what you're asking. DoEvents isn't a counter function, it tells the OS that the current app is willing to relinquish control of the CPU at this point to allow other OS tasks to run. I'm talking about creating a new counter variable that you increment each time you're finished proceeding an e-mail. When it hits 10 (or 100) DoEvents and reset the counter to 0. That will minimize the amount of time you willingly relinquish the CPU while still being a nice Windows citizen. – FreeMan Jun 7 '17 at 9:50
• Ok, now I understand, thanks for the follow up. – DGMS89 Jun 7 '17 at 10:14
• No worries. To be clear, the OS will suspend your thread whenever it needs to, DoEvents just says "I'm voluntarily relinquishing control here." Frankly, as much switching that you're doing between Excel and Outlook, you probably don't need it at all, but it is a courteous thing to do. – FreeMan Jun 7 '17 at 10:20
• Just one more random doubt: If in my worksheets to be downloaded I had names such as "alpha" and "ia alpha" (not in the same workbook, but in different files), could I account for this difference using the instring function? – DGMS89 Jun 7 '17 at 10:56