Outlook macro - MAPIFolder looping extremely slow


Joined
Mar 22, 2013
Messages
1
Reaction score
0
Hi guys,

I'm new to VB and Outlook but have managed to throw together the code below to help me file emails. By putting emails in the correct format into a folder called "AUTOFILE" the macro moves the emails into their respective client folders. Everything is working which is great.. however it is extremely slow and I can't figure out why. There is at most 3k nested folders in any given alphabetical folder ,yet the macro can take over 20 seconds to run for a single mail. Could anybody explain to me why the code is running so slowly? Thanks in advance!

Code:
Sub AUTOFILE()
    Filer ("AUTOFILE")
End Sub

Sub AlertAUTOFILE()
    Filer ("AlertAUTOFILE")
End Sub

Sub Filer(fileType As String)

'Refrence-> add-> microsoft outlook
Dim ol As Outlook.Application
Dim olns As Outlook.NameSpace
Dim oinbox As Outlook.folder
Dim oitem As Outlook.MailItem
Dim x() As String
Dim y As String
Dim accountName As String
Dim accountLetter As String
Dim FolderPath As String
Dim moveFolder As Outlook.folder
Dim accountTemp As String
Dim seperator As String

' set outlook objects
Set ol = New Outlook.Application
Set olns = ol.GetNamespace("MAPI")
Set oinbox = olns.GetDefaultFolder(olFolderInbox)

'TODO--- Deal with G-L and separate H I J K L client folders

Debug.Print "-----------------" & fileType & " begin---------------------" & vbCrLf

    If fileType = "AUTOFILE" Then
      seperator = "/"
    ElseIf fileType = "AlertAUTOFILE" Then
      seperator = "|"
    End If
    
  'These are used to avoid searching for folders multiple times
  'when the previous email came from the same account
  accountTemp = "--£$%%£%WONTBESUBJECT.,"
  folderPathTemp = "not found"
    
  'Iterates from the end backwards to stop moves breaking loop
  For i = oinbox.Parent.Folders(fileType).Items.Count To 1 Step -1
  Set oitem = oinbox.Parent.Folders(fileType).Items(i)
    
    'Remove common stuff from front of string
    y = oitem.Subject
    y = LCase(y)
    y = Replace(y, "out of office autoreply:", "")
    y = Replace(y, "out of office:", "")
    y = Replace(y, "automatic reply:", "")
    y = Replace(y, "fw:", "")
    y = Replace(y, "fwd:", "")
    y = Replace(y, "re:", "")


    y = Replace(y, "[", "")
        
    'Get part of subject with client ID
    If InStr(y, seperator) > 0 Then
        
      x = Split(y, seperator, 2)
      x(0) = RTrim(x(0))
      x(0) = LTrim(x(0))
            
      accountName = x(0)
      
      If accountTemp = accountName Then
        FolderPath = folderPathTemp
        GoTo SamePath
      Else
        accountTemp = accountName
      End If
            
      'Still spaces? - then not an ID => skip
      If InStr(accountName, " ") Then
        Debug.Print "Account name extraction failed: " & accountName
        GoTo ContinueLoop
      End If
            
      Debug.Print "Account name: |" & accountName & "|"
            
      'Pull out first letter of client ID
      accountLetter = Left(UCase(accountName), 1)
            
      '----------Remove once client folders have been cleaned up
      If accountLetter = "G" Or accountLetter = "H" _
                            Or accountLetter = "I" Or accountLetter = "J" _
                            Or accountLetter = "K" Or accountLetter = "L" Then
        'accountLetter = "G-L"
     
      ElseIf accountLetter = "M" Or accountLetter = "N" _
                            Or accountLetter = "O" Or accountLetter = "P" _
                            Or accountLetter = "Q" Or accountLetter = "R" Then
        accountLetter = "M-R|M|M - R"
     
      ElseIf accountLetter = "S" Or accountLetter = "T" Or accountLetter = "U" Then
        accountLetter = "S-U"
     
      ElseIf accountLetter = "V" Or accountLetter = "W" _
                           Or accountLetter = "X" Or accountLetter = "Y" Then
        accountLetter = "V-Y"
      
      ElseIf accountLetter = "0" Or accountLetter = "1" Or accountLetter = "2" _
                           Or accountLetter = "3" Or accountLetter = "4" _
                           Or accountLetter = "5" Or accountLetter = "6" _
                           Or accountLetter = "7" Or accountLetter = "8" _
                           Or accountLetter = "9" Then
        accountLetter = "0-9"
        
      End If
      '----------
            
      Debug.Print "Searching for folder..."
      FolderPath = GetPath(accountLetter & "|" & accountName)
SamePath:
      If FolderPath = "not found" Then
        folderPathTemp = FolderPath
        GoTo ContinueLoop:
     
      Else
        'Set destination folder to correct path
        FolderPath = Replace(FolderPath, "|", "\")
        folderPathTemp = FolderPath

        Debug.Print FolderPath & " found! Moving email..."
        Set moveFolder = GetFolder(FolderPath)
        'Move mail to client folder if found
        oitem.Move moveFolder
        Debug.Print "Done!" & vbCrLf
     End If
'Hacky java like continue
ContinueLoop:
    End If
  Next
  
Debug.Print "-----------------" & fileType & " complete------------------"
    
End Sub

Function GetPath(ClientFolderName As String)

  'This function returns a folder path

  Dim FolderNameTgt As String
  Dim FolderTgt As MAPIFolder

  'Path to folder
  'If you use "|" in your folder names, pick a different
  'separator and change the call of TopLevelSearch().
  FolderNameTgt = "ClientFolders|Inbox|Customers|" & ClientFolderName
  
  Call TopLevelSearch(FolderTgt, FolderNameTgt, "|")
  If FolderTgt Is Nothing Then
    
    Debug.Print FolderNameTgt & " not found" & vbCrLf
    GetPath = "not found"
  Else
    'Debug.Print FolderNameTgt & " found: " & FolderTgt.Name
    GetPath = FolderNameTgt
  End If

End Function

Sub TopLevelSearch(ByRef FolderTgt As MAPIFolder, NameTgt As String, NameSep As String)

  'This routine initialises the search and finds the top level folder

  Dim InxFolderCrnt As Integer
  Dim NameChild As String
  Dim NameCrnt As String
  Dim Pos As Integer
  Dim TopLvlFolderList As Folders

  Set FolderTgt = Nothing   ' Target folder not found

  Set TopLvlFolderList = _
          CreateObject("Outlook.Application").GetNamespace("MAPI").Folders

  'Split NameTgt into the name of folder at current level
  'and the name of its children
  Pos = InStr(NameTgt, NameSep)
  If Pos = 0 Then
    'I need at least a level 2 name
    Exit Sub
  End If
  NameCrnt = Mid(NameTgt, 1, Pos - 1)
  NameChild = Mid(NameTgt, Pos + 1)

  'Look for current name - Drop through and return nothing if name not found.
  For InxFolderCrnt = 1 To TopLvlFolderList.Count
    If NameCrnt = TopLvlFolderList(InxFolderCrnt).Name Then
      'Have found current name. Call NestedSearch() to look for its children
      Debug.Print NameCrnt
      Call NestedSearch(TopLvlFolderList.Item(InxFolderCrnt), _
                                            FolderTgt, NameChild, NameSep)
      Exit For
    End If
  Next

End Sub

Sub NestedSearch(FolderCrnt As MAPIFolder, ByRef FolderTgt As MAPIFolder, _
                                         NameTgt As String, NameSep As String)

  'This routine finds all folders below the top level

  Dim InxFolderCrnt As Integer
  Dim NameChild As String
  Dim NameCrnt As String
  Dim Pos As Integer

  'Split NameTgt into the name of folder at current level
  'and the name of its children
  Pos = InStr(NameTgt, NameSep)
  If Pos = 0 Then
    NameCrnt = NameTgt
    NameChild = ""
  Else
    NameCrnt = Mid(NameTgt, 1, Pos - 1)
    NameChild = Mid(NameTgt, Pos + 1)
  End If

  'Look for current name.  Drop through and return nothing if name not found.
  For InxFolderCrnt = 1 To FolderCrnt.Folders.Count
    If NameCrnt = FolderCrnt.Folders(InxFolderCrnt).Name Then
      Debug.Print NameCrnt
      'Have found current name.
      If NameChild = "" Then
        'Have found target folder
        Set FolderTgt = FolderCrnt.Folders(InxFolderCrnt)
      Else
        'Recurse to look for children
        Call NestedSearch(FolderCrnt.Folders(InxFolderCrnt), _
                                            FolderTgt, NameChild, NameSep)
      End If
      Exit For
    End If
  Next

End Sub

Function GetFolder(ByVal FolderPath As String) As Outlook.folder

 'This function converts a folder path to a Folder object (if it exists)

 Dim TestFolder As Outlook.folder
 Dim FoldersArray As Variant
 Dim i As Integer
 
    On Error GoTo GetFolder_Error
    If Left(FolderPath, 2) = "\\" Then
      FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    
    'Convert folderpath to array
    FoldersArray = Split(FolderPath, "\")
    Set TestFolder = Application.Session.Folders.Item(FoldersArray(0))
    
    If Not TestFolder Is Nothing Then
      For i = 1 To UBound(FoldersArray, 1)
        Dim SubFolders As Outlook.Folders
        Set SubFolders = TestFolder.Folders
        Set TestFolder = SubFolders.Item(FoldersArray(i))
        If TestFolder Is Nothing Then
          Set GetFolder = Nothing
        End If
      Next
    End If
    
    'Return the TestFolder
    Set GetFolder = TestFolder
    Exit Function
 
GetFolder_Error:
 Set GetFolder = Nothing
 Exit Function
 
End Function
 
Ad

Advertisements


Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top