Slow VBA macro in Outlook

Status
Not open for further replies.

Martinoso

New Member
Outlook version
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 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.
 
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:
uup, sorry for the formatting. i still don´t know how to enter code here ;-)
 
Status
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
Commodore Slow calendar Using Outlook 0
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 Using Outlook 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
M bcm painfully slow BCM (Business Contact Manager) 1
C Outlook 2003 very slow to open Using Outlook 5
H using VBA to edit subject line Outlook VBA and Custom Forms 0
G Get current open draft message body from VBA Outlook VBA and Custom Forms 1
Geldner Problem submitting SPAM using Outlook VBA Form Outlook VBA and Custom Forms 2
P VBA to add email address to Outlook 365 rule Outlook VBA and Custom Forms 0
M Outlook 2016 outlook vba to look into shared mailbox Outlook VBA and Custom Forms 0
V VBA Categories unrelated to visible calendar and Visual appointment Categories Outlook VBA and Custom Forms 2
D Outlook VBA forward the selected email to the original sender’s email ID (including the email used in TO, CC Field) from the email chain Outlook VBA and Custom Forms 2
R Outlook 365 VBA AUTO SEND WITH DELAY FOR EACH EMAIL Outlook VBA and Custom Forms 0
R Outlook 2019 VBA to List Meetings in Rooms Outlook VBA and Custom Forms 0
geoffnoakes Counting and/or listing fired reminders via VBA Using Outlook 1
O VBA - Regex - remove double line spacing Outlook VBA and Custom Forms 1
D.Moore Strange VBA error Outlook VBA and Custom Forms 4
B Modify VBA to create a RULE to block multiple messages Outlook VBA and Custom Forms 0
D Outlook 2021 Using vba code to delete all my spamfolders not only the default one. Outlook VBA and Custom Forms 0
K vba code to auto download email into a specific folder in local hard disk as and when any new email arrives in Inbox/subfolder Outlook VBA and Custom Forms 0
D VBA - unable to set rule condition 'on this computer only' Outlook VBA and Custom Forms 5
L Fetch, edit and forward an email with VBA outlook Outlook VBA and Custom Forms 2
BartH VBA no longer working in Outlook Outlook VBA and Custom Forms 1
W Can vba(for outlook) do these 2 things or not? Outlook VBA and Custom Forms 2
MattC Changing the font of an email with VBA Outlook VBA and Custom Forms 1
P MailItem.To Property with VBA not work Outlook VBA and Custom Forms 2

Similar threads

Back
Top