Slow VBA macro in Outlook

[Martinoso]

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:

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

 

[Diane Poremsky]

Michael might have a better idea... but I think Find or Restrict functions will be faster, even if you have to do it 6 times, once for each keyword. Then you'll loop the results and check the attachments.

 

[Michael Bauer]

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.

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

 

[Michael Bauer]

uup, sorry for the formatting. i still don´t know how to enter code here ;-)

 

[Diane Poremsky]

i still don´t know how to enter code here ;-)

wrap it in [ code ] and [ / code ] (without spaces inside the [] )

(i fixed it for you)

 

[Michael Bauer]

thanks