Outlook VBA Search Slowness

[heffo500]

Hi

I use the below code to save down attachments from our outlook accounts to our shared drive. For me it works perfectly on Windows 10, a colleague was on Windows 7 and it worked perfect for him until he migrated to Win 10.

My Inbox has 20k items while theirs has 30k. The codes starts at the last item in the inbox and searches up until it finds the item with the subject.

It always saves the file from the most recent email and this is crucial as we receive the same sales report daily.

Anyone any ideas why its so slow for me colleague or how I could amend it to speed up, Could I change the code to search from the most recent email to the oldest as it seems to go in the other direction? Would that speed things?

Thanks






Sub SaveDownAttachment()
Dim myOlApp As Outlook.Application
Dim myInspector As Outlook.Inspector
Dim myItem As Outlook.MailItem
Dim myAttachments As Outlook.Attachments

Dim Folder As Outlook.MAPIFolder
Dim sFolders As Outlook.MAPIFolder
Dim iRow As Long, oRow As Integer
Dim MailBoxName As String, Pst_Folder_Name As String
Dim myname As String
Dim Email As String

myname = Application.UserName
Email = Right(myname, Len(myname) - WorksheetFunction.Search(" ", myname)) & "." & Left(myname, WorksheetFunction.Search(",", myname) - 1) & "@emailaccount.com"


MailBoxName = Email

Pst_Folder_Name = "Inbox"

For Each Folder In Outlook.Session.Folders(MailBoxName).Folders
If VBA.UCase(Folder.Name) = VBA.UCase(Pst_Folder_Name) Then GoTo Label_Folder_Found
For Each sFolders In Folder.Folders
If VBA.UCase(sFolders.Name) = VBA.UCase(Pst_Folder_Name) Then
Set Folder = sFolders
GoTo Label_Folder_Found
End If
Next sFolders
Next Folder
Label_Folder_Found:
If Folder.Name = "" Then
MsgBox "Invalid Data in Input"
GoTo End_Lbl1:
End If
On Error Resume Next
For iRow = Folder.Items.Count To 1 Step -1

If Folder.Items.Item(iRow).Subject = "[EXT] Sales Report" Then
Set myOlApp = CreateObject("Outlook.Application")
Set myItem = Folder.Items.Item(iRow)
Set myAttachments = myItem.Attachments
myAttachments.Item(1).SaveAsFile "G:\TeamDrive\SalesReport.xls"
Exit Sub
End If
Next iRow
exitsub:

Set Folder = Nothing
Set sFolders = Nothing

End_Lbl1:
End Sub

 

[bobsan42]

I guess there is always room for code improvement. But i think it may not help. If the code ran fast and well before and there were system changes then i guess that there is a new outlook setup. And probably new connection settings. MayBE before it was pop3 and now it's IMAP. Maybe now the emails are not downloaded to the computer but only the lists are synchronized. Check these possibilities first. Try to run the macro on two different computers/connections/accounts with different settings.