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