Slow VBA macro in Outlook

Status
Not open for further replies.

Martinoso

New Member
Outlook version
Outlook 2007
Email Account
Outlook.com (as MS Exchange)
Hello, I have a VBA macro in my Outlook, which takes around 60 minutes to process around 45k emails. I was wondering, whether there is a way to somehow speed it up. I'd be very grateful for some suggestions. Here's the code:

Code:
Option Explicit
Option Compare Text

'References : Microsoft Outlook 16.0 Object Library
'--------------------------------------------------

Declare Function WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
Const NoError = 0

Sub SearchandDownload()

    On Error Resume Next

    Dim ns              As NameSpace
    Dim Inbox           As MAPIFolder
    Dim Item            As Object
    Dim atmt            As attachment
    Dim fileName        As String
    Dim i               As Long
    Dim itemsCount      As Long
    Dim StartTime As Double
    Dim MinutesElapsed As String


    StartTime = Timer
   
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    i = 0
    itemsCount = Inbox.Items.Count

    If itemsCount = 0 Then
        MsgBox "There are no valid emails in your Inbox.", vbInformation, "Nothing Found"
        Exit Sub
    End If
   
    For Each Item In Inbox.Items
   
    If InStr(Item.Body, "pass") > 0 Or InStr(Item.Body, "certifi") > 0 Or InStr(Item.Body, "licen") > 0 Or InStr(Item.Body, "secur") > 0 _
    Or InStr(Item.Body, "acco") > 0 Then

    For Each atmt In Item.Attachments
   
        If atmt.Size > 45000 Then
       
                If fileName = "" Then
                    Call CreateFolder
                End If
               
                fileName = MyDocs() & Item.SenderName & " " & atmt.fileName
                atmt.SaveAsFile fileName
                i = i + 1
               
            End If
            Next atmt
        End If
       
    For Each atmt In Item.Attachments
            If InStr(atmt.fileName, "port") > 0 Or InStr(atmt.fileName, "certifie") > 0 Or InStr(atmt.fileName, "lice") > 0 Or InStr(atmt.fileName, "secu") > 0 _
            Or InStr(atmt.fileName, "accou") > 0  Then
 
                If fileName = "" Then
                    Call CreateFolder
                End If
    
                fileName = MyDocs() & Item.SenderName & " " & atmt.fileName
                atmt.SaveAsFile fileName
                i = i + 1
            End If
           
             If Right(atmt.fileName, 3) = "pdf" Or Right(atmt.fileName, 3) = "jpg" And atmt.Size > 45000 Or Right(atmt.fileName, 3) = "JPG" And atmt.Size > 45000 Then
  
                If fileName = "" Then
                    Call CreateFolder
                End If
            
                fileName = MyDocs() & Item.SenderName & " " & atmt.fileName
                atmt.SaveAsFile fileName
                i = i + 1
            End If
           
        Next atmt
  
    Next Item
        
    MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
   
    If i > 0 Then
        MsgBox "The attached files detected were saved into the Email Attachments folder in My Documents. This code ran successfully in " & MinutesElapsed & " minutes", vbInformation

    Else
        MsgBox "There are no attached files in your Inbox.", vbInformation, "Finished!"
    End If

End Sub

Function GetUserName()
    Const lpnLength     As Integer = 255
    Dim status          As Integer
    Dim lpName          As String
    Dim lpUserName      As String

    lpUserName = Space$(lpnLength + 1)
    status = WNetGetUser(lpName, lpUserName, lpnLength)

    If status = NoError Then
        lpUserName = Left$(lpUserName, InStr(lpUserName, Chr(0)) - 1)
    Else
        MsgBox "Unable To Get The Name", vbExclamation
        End
    End If
   
    GetUserName = lpUserName
End Function

Function MyDocs() As String
    Dim strStart        As String
    Dim strEnd          As String
    Dim strUser         As String

    strUser = GetUserName()
    strStart = "C:\Documents and Settings\"
    strEnd = "\My Documents\Email Attachments\"

    MyDocs = strStart & strUser & strEnd
End Function

Private Sub CreateFolder()
    Dim wsh             As Object
    Dim fs              As Object
    Dim destFolder      As String
    Dim myDocPath       As String

    If destFolder = "" Then
        Set wsh = CreateObject("WScript.Shell")
        Set fs = CreateObject("Scripting.FileSystemObject")
       
        myDocPath = wsh.SpecialFolders.Item("mydocuments")
        destFolder = myDocPath & "\Email Attachments"
       
        If Not fs.FolderExists(destFolder) Then
            fs.CreateFolder destFolder
        End If
    End If
End Sub
 

Michael Bauer

Senior Member
Outlook version
Outlook 2010 32 bit
Email Account
Exchange Server
The code indeed is pretty unefficiently: MyDocs is called multiple times although it returns always the same value, and it loops at least twice, if not three times, through each items attachments.

Also, VBA doesn´t use the OR in the If statement efficiently, that is it checks each part even if the first one is already true.

However, the most time wasting part could be that it very likely saves some attachments, if not all, multiple times. Not sure if that´s your intention but at present it saves attachments of emails with a certain phrase in the body only if the attachment has a certain size, but then it also saves all pdfs, jpgs, etc. of all emails. For instance, a pdf of more than 45000 in size with "port" in its name and "pass" in the emails body will be saved three times, each time overriding the existing file.

I´d use something like this, which saves an attachment only once no matter which ceriteria was met. Start with the most common criteria. The Select Case for the file´s extension is the fastest search, and use more time consuming searches only if necessary.

Code:
dim ok as boolean
dim fname as string
dim docs as string
dim largeatts as collection
dim savethisone as collection
docs=mydocs
for each item in items
  'reset
  set largeatts=new collection
  set savethisone =new collection
  for each att in attachments
    'reset
    ok=false
    'turn the name to lower cases if the search should be case-insensitive
    'also accessing the property only once is faster
    fname=lcase$(att.filename)
    'first check for the most common criteria
    select case right(fname,3)
      case "pdf", "jpg", ...
        ok=true
        savethisone.add att
    end select
    if ok=false then     
      if instr(fname, ...) then
        ok=true
      elseif instr(fname, ...) then
        ok=true
      endif
      if ok then
        savethisone.add att
      elseif att.size>45000 then
        'no match so far, however, it exceeds a certain size
        largeatts.add att
      endif
    endif
  next att
  for each att in largeatts
    'this one is also case-insensitive
    if instr(1, item.body, ..., vbtextcompare) then
      savethisone.add att
    elseif instr(1, item.body, ..., vbtextcompare) then
      savethisone.add att
    endif
  next att
  for each att in savethisone
    'do save
  next att
next item
 
Last edited by a moderator:

Michael Bauer

Senior Member
Outlook version
Outlook 2010 32 bit
Email Account
Exchange Server
uup, sorry for the formatting. i still don´t know how to enter code here ;-)
 
Status
Not open for further replies.
Thread starter Similar threads Forum Replies Date
N Outlook is very slow Using Outlook 0
M Ignore slow add-ins Using Outlook 0
S Adding new Exchange (2016) rule very slow down Microsoft Outlook Exchange Server Administration 0
1 Opens Slow Using Outlook 4
Cdub27 Move Outlook 2016 Contacts to Other Folders - Extremely Slow !! Using Outlook 6
D Very slow when digitally signed Exchange Server Administration 0
Diane Poremsky Office for Mac: Insider Fast and Slow Builds New Slipstick.com Articles 0
M Very slow operation Using Outlook 0
R Slow character rendering after Hebrew used Using Outlook 1
I Outlook 2016 and Slow access to Outlook.com IMAP Using Outlook 0
B very slow attachments Using Outlook 5
T Outlook 2010 Very Slow To Open Recently Using Outlook 9
Sarge USMC troubleshooting slow startup Using Outlook 6
I Outlook 03 slow startup Using Outlook 5
B Outlook suddenly very slow Using Outlook 4
R Exchange 2013/Outlook 2010 Slow Startups Exchange Server Administration 8
B Outlook 2013 slow or no receipt of emails Using Outlook 0
R Slow Calendar Synch Between Outlook 2013 and iCloud Using Outlook 5
D Outlook 2000 slow Using Outlook 2
P Oulook 2010 very slow Using Outlook 2
B Slow to receive emails on Outlook 2013 Using Outlook 35
Z "Mark All as Read" in Outlook 2007 extremely slow Using Outlook 1
B Outlook 2007 - Slow opening folders when inserting attachments Using Outlook 2
A Outlook 2010 slow with Yahoo IMAP Using Outlook 1
M BCM 2010 Link to Record (very) slow BCM (Business Contact Manager) 2
D Outlook 2010, super slow! IMAP issue I think Using Outlook 1
P slow access from folder to folder Using Outlook 2
R Slow and frustrating Using Outlook 1
C Folders slow to open__ Using Outlook 1
N outlook 2007 slow with signed e-mails Using Outlook 1
B Switching folders is very slow Using Outlook 2
D Outlook 2007 Slow Since Office 2010 Installed Using Outlook 1
N Slow / non response trying to pass from one folder to other (both in OUTLOOK.PST) Using Outlook 2
J Outlook changing from inbox/trash/sent, etc. is EXTREMELY slow since updating Windows a couple of days ago. Is there an issue with Outlook as to the Using Outlook 2
A Outlook slow Using Outlook 2
O Outlook slow to change between folders Using Outlook 3
O Slow loading when switching from folder to folder in Outlook Using Outlook 2
K Slow navigation Using Outlook 1
T Folders slow to open Using Outlook 1
G Outlook 2007 is Slow Using Outlook 3
C Outlook Folders Slow to Load Using Outlook 2
P Changing between multiple inboxes, loading messages is slow Using Outlook 6
B Very slow performace when switching between mail folders. Using Outlook 4
B Outlook 2007 is very slow to switch between mail, contacts, and calendar. Using Outlook 2
R Outlook 2007 increadibly slow after compacting .pst file Using Outlook 4
L Outlook 2007 slow to switch view from one folder to another Using Outlook 8
D Opening files in Mail Folders takes 15 seconds - running slow ? Using Outlook 4
O Outlook 2007 Ultimate Slow after December Update Using Outlook 8
A Outlook after recent updates super slow, SPA login does not work. Using Outlook 14
F update 2412171 made my outlook run slow, very Email removed for privacy Using Outlook 6
Similar threads


















































Top