Sorry for the long post, I'm still a self taught amateur: but my project is to automate some tasks during which I can filter outlook mails potentially by Sender, and subject, and send them to specific folders. (For certain reasons I can't use the built in Outlook filter). The code below works fine, but some of the boxes the macro accesses are located on a server in another country, so some of the actions take a long time. Essentially, my code loops through a list of email addresses to filter out, and potential subject lines. It goes through every single email, compares sender name and subject, then determines which folder to send it to, and moves it.
My question is how can I make this more efficient, by either using more clever code, or reducing total number of actions? Is there a more efficient way to search through all of the emails rather than 1 by 1? Instead of moving 1 by 1, is it possible to move them all in blocks? I'd be so appreciative if someone could help. My code is below (I realize there are some unneccesary lines but I use some of this for multiple projects). Thanks so much!
Const olFolderInbox As Integer = 6
Option Compare Text
Sub Filter()
Dim outlookApp As Outlook.Application, oOutlook As Object
Dim oInbox As Outlook.Folder, oMail As Outlook.MailItem
Dim i, j As Integer
Dim strAddress As String, strEntryId As String, getSmtpMailAddress As String
Dim objAddressentry As Outlook.AddressEntry, objExchangeUser As Outlook.ExchangeUser
Dim objReply As Outlook.MailItem, objRecipient As Outlook.Recipient
Dim oAccount As Outlook.Account
Dim oOlAp As Object, oOlns As Object, oOlInb As Object
Dim oOlItm As Object
Dim Br, Spec As Folder
Dim oOlAtch As Object
Dim eSender As String, dtRecvd As String, dtSent As String, o0Acct1 As String, o0Acct2 As String
Dim sSubj As String, sMsg As String
Dim wb As Workbook, wb2 As Workbook
Dim fso As FileSystemObject
Dim FName, NewFileName As String
Dim sn, Subject, F, F2, SF, SF2, SFF, SFF2, From, SJ As String
'Set objects
'=============================
Set outlookApp = New Outlook.Application
Set oOutlook = outlookApp.GetNamespace("MAPI")
Set oInbox = oOutlook.GetDefaultFolder(olFolderInbox)
'~~> Get Outlook instance
Set myNS = GetNamespace("MAPI")
i = 0
For Each Adds In Range("Adds")
i = i + 1
MB = Range("MBs")(i)
F = Range("FromsF")(i)
F2 = Range("TosF")(i)
SF = Range("FromsSF")(i)
SF2 = Range("TosSF")(i)
SSF = Range("FromsSSF")(i)
SSF2 = Range("TosSSF")(i)
From = Range("Adds")(i)
SJ = Range("Subs")(i)
With myNS
For Each Folder In myNS.Folders
If Folder = MB Then
If SSF = "" Then
Set Br = Folder.Folders(F).Folders(SF)
Else
Set Br = Folder.Folders(F).Folders(SF).Folders(SSF)
End If
If SSF2 = "" Then
Set ToF = Folder.Folders(F).Folders(SF2)
Else
Set ToF = Folder.Folders(F).Folders(SF2).Folders(SSF2)
End If
For j = Br.Items.Count To 1 Step -1 'loop goes from last to first element
' ----Find Sender's Name
If Br.Items(j).SenderEmailType = "SMTP" Then
sn = Br.Items(j).SenderEmailAddress
Else
Set objReply = Br.Items(j).Reply()
Set objRecipient = objReply.Recipients.Item(1)
strEntryId = objRecipient.EntryID
objReply.Close OlInspectorClose.olDiscard
strEntryId = objRecipient.EntryID
Set objAddressentry = oOutlook.GetAddressEntryFromID(strEntryId)
Set objExchangeUser = objAddressentry.GetExchangeUser()
On Error Resume Next
sn = objExchangeUser.PrimarySmtpAddress()
End If
'----------------If sender is equal to our address
If sn = From Then
If SJ <> "" Then
SJ = "*" & Range("Subs")(i) & "*"
Subject = Br.Items(j).Subject
If Subject Like SJ Then
Br.Items(j).Move ToF
Else
End If
Else
Br.Items(j).Move ToF
End If
Else
End If
Next j
Else
End If
Next Folder
End With
Next Adds
End Sub
Edit ----------------------------------
So here is my new code.
Const olFolderInbox As Integer = 6
Option Compare Text
' FLIRTER WITH DATE FILTERING
Sub FilterTry()
Dim outlookApp As Outlook.Application, oOutlook, TargetMail As Object
Dim oInbox As Outlook.Folder, oMail As Outlook.MailItem
Dim i, j As Integer
Dim objAddressentry As Outlook.AddressEntry, objExchangeUser As Outlook.ExchangeUser
Dim objReply As Outlook.MailItem, objRecipient As Outlook.Recipient
Dim oAccount As Outlook.Account
Dim oOlAp As Object, oOlItm, oOlAtch, oOlns As Object, oOlInb As Object
Dim Br, Spec As Folder
Dim eSender As String, dtRecvd As String, dtSent As String, o0Acct1 As String, o0Acct2 As String
Dim sSubj As String, sMsg As String
Dim wb As Workbook, wb2 As Workbook
Dim fso As FileSystemObject
Dim FName, NewFileName As String
Dim sn, Subject, F, F2, SF, SF2, SFF, SFF2, SJ, From, SJstrAddress As String, strEntryId, getSmtpMailAddress As String
Dim td, SentDate As Date
'Set objects
Set outlookApp = New Outlook.Application
Set oOutlook = outlookApp.GetNamespace("MAPI")
Set oInbox = oOutlook.GetDefaultFolder(olFolderInbox)
'~~> Get Outlook instance
Set oOlAp = GetObject(, "Outlook.application")
Set oOlns = oOlAp.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
Set Br = oOlInb.Folders("Brokers")
Set Sp = oOlInb.Folders("Confirmation")
Set Rc = oOlInb.Folders("Recap")
Set oOlItm = Br.Items
Set myNS = GetNamespace("MAPI")
i = 0
'----Set variables for folders
For Each Adds In Range("Adds")
If Adds <> "" Then
i = i + 1
MB = Range("MBs")(i)
F = Range("FromsF")(i)
F2 = Range("TosF")(i)
SF = Range("FromsSF")(i)
SF2 = Range("TosSF")(i)
SSF = Range("FromsSSF")(i)
SSF2 = Range("TosSSF")(i)
From = Range("Adds")(i)
SJ = Range("Subs")(i)
td = Range("Ddate")
With myNS
'----- Set To and From Destination folders
For Each Folder In myNS.Folders
If Folder = MB Then
If SSF = "" Then
Set Br = Folder.Folders(F).Folders(SF)
Else
Set Br = Folder.Folders(F).Folders(SF).Folders(SSF)
End If
If SSF2 = "" Then
Set ToF = Folder.Folders(F).Folders(SF2)
Else
Set ToF = Folder.Folders(F).Folders(SF2).Folders(SSF2)
End If
sFilter = "[SenderName] = " & From
Set Items = Br.Items.Restrict(sFilter)
msg = Items.Count
For q = Items.Count To 1 Step -1 'loop goes from last to first element
sn = Items(q).SenderEmailAddress
SentDt = Items(q).SentOn
SentDate = Month(SentDt) & "/" & Day(SentDt) & "/" & Year(SentDt)
sn = Items(q).Subject
If SentDate >= td Then
' ----Find Sender's Name
If Items(q).SenderEmailType = "SMTP" Then
sn = Items(q).SenderEmailAddress
Else
sn = Items(q).PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001F")
If Len(sn) = 0 Then
Set objSender = Items(q).Sender
If Not (objSender Is Nothing) Then
'read PR_SMTP_ADDRESS_W
sn = objSender.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001F")
If Len(sn) = 0 Then
'last resort
Set exUser = objSender.GetExchangeUser
If Not (exUser Is Nothing) Then
sn = exUser.PrimarySmtpAddress
End If
End If
End If
End If
End If
'----------------If sender is equal to our address
If SJ <> "" Then
SJ = "*" & Range("Subs")(i) & "*"
Subject = Items(q).Subject
If Subject Like SJ Then
Items(q).Move ToF
Else
End If
Else
Items(q).Move ToF
End If
Else
End If
Next q
Else
End If
Next Folder
End With
Else
End If
Next Adds
End Sub
