Thanks Thanks:  0
Likes Likes:  0
Results 1 to 2 of 2

Thread: Outlook VBA Search Slowness

  1. #1
    New Member
    Join Date
    Sep 2016
    Post Thanks / Like
    0 Post(s)
    0 Thread(s)

    Default Outlook VBA Search Slowness


    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?


    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) & ""

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

    Set Folder = Nothing
    Set sFolders = Nothing

    End Sub

  2. #2
    Board Regular bobsan42's Avatar
    Join Date
    Jul 2010
    Bulgaria, GMT+2 (42.891813,25.313594)
    Post Thanks / Like
    6 Post(s)
    0 Thread(s)

    Default Re: Outlook VBA Search Slowness

    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.
    "'s sad that in our blindness we gather thorns for flowers..."
    mostly using:
    windows 7 +10 (64-bit) / excel 2013 +2016 (32-bit) / access 2013 +2016 (32-bit) / some imagination & Google of course
    You don't need to read between the lines - just read them all!

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts