So apparently here this macro fetches specific email addresses from inbox as well as sent items along with email addresses from cc,bcc
the problem is it takes a whole lot of time and i mean if a person has 2k emails he might have to wait for 3 to 4 hours .
Check some sources how to make code faster i got to know about restrict function when applied through DASL filter and limit number of items in a loop. i applied the same but the result is still the same and fetching is still slow .
As new into VBA i dont know all about optimization and still learning.
Any other sources or ways to make the fetching and execution faster ?
code given for reference
Option Explicit
Sub GetInboxItems()
'all vars declared
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim fol As Outlook.Folder
Dim i As Object
Dim mi As Outlook.MailItem
Dim n As Long
Dim seemail As String
Dim seAddress As String
Dim varSenders As Variant
'for sent mails
Dim a As Integer
Dim b As Integer
Dim objitem As Object
Dim take As Outlook.Folder
Dim xi As Outlook.MailItem
Dim asd As String
Dim arr As Variant
Dim K As Long
Dim j As Long
Dim vcc As Variant
Dim seemail2 As String
Dim seAddress2 As String
Dim varSenders2 As Variant
Dim strFilter As String
Dim strFilter2 As String
'screen wont refresh untill this is turned true
Application.ScreenUpdating = False
'now assigning the variables and objects of outlook into this
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.GetDefaultFolder(olFolderInbox)
Set take = ns.GetDefaultFolder(olFolderSentMail)
Range("A3", Range("A3").End(xlDown).End(xlToRight)).Clear
n = 2
strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:fromemail" & Chr(34) & " like '%" & seemail & "'"
strFilter2 = "@SQL=" & Chr(34) & "urn:schemas:httpmail:sentitems" & Chr(34) & " like '%" & seemail2 & "'"
'this one is for sent items folder where it fetches the emails from particular people
For Each objitem In take.Items.Restrict(strFilter2)
If objitem.Class = olMail Then
Set xi = objitem
n = n + 1
seemail2 = Worksheets("Inbox").Range("D1")
varSenders2 = Split(seemail2, ";")
For K = 0 To UBound(varSenders2)
'this is the same logic as the inbox one where if mail is found and if the mail is of similar kind then and only it will return the same
If xi.SenderEmailType = "EX" Then
seAddress2 = xi.Sender.GetExchangeUser.PrimarySmtpAddress
If InStr(1, seAddress2, varSenders2(K), vbTextCompare) Then
Cells(n, 1).Value = xi.Sender.GetExchangeUser().PrimarySmtpAddress
Cells(n, 2).Value = xi.SenderName
ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
On Error Resume Next
Range("A3:A9999").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
'this is the smpt address (regular address)
ElseIf xi.SenderEmailType = "SMTP" Then
seAddress2 = xi.SenderEmailAddress
If InStr(1, seAddress2, varSenders2(K), vbTextCompare) Then
Cells(n, 1).Value = xi.SenderEmailAddress
Cells(n, 2).Value = xi.SenderName
ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
On Error Resume Next
Range("A3:A9999").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
'this one fetches the cc part recipient denotes cc
For j = xi.Recipients.Count To 1 Step -1
If (xi.Recipients.Item(j).AddressEntry.Type = "EX") Then
vcc = xi.Recipients.Item(j).Address
If InStr(1, vcc, varSenders2(K), vbTextCompare) Then
Cells(n, 1).Value = xi.Recipients.Item(j).AddressEntry.GetExchangeUser.PrimarySmtpAddress
Cells(n, 2).Value = xi.Recipients.Item(j).Name
ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
On Error Resume Next
Range("A3:A9999").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
Else
vcc = xi.Recipients.Item(j).Address
If InStr(1, vcc, varSenders2(K), vbTextCompare) Then
Cells(n, 1).Value = xi.Recipients.Item(j).Address
Cells(n, 2).Value = xi.Recipients.Item(j).Name
ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
On Error Resume Next
Range("A3:A9999").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
End If
Next j
Else: seAddress2 = ""
End If
For a = 1 To take.Items.Count
n = 3
'this also fetches the recipient emails
If TypeName(take.Items(a)) = "MailItem" Then
For b = 1 To take.Items.Item(a).Recipients.Count
asd = take.Items.Item(a).Recipients(b).Address
If InStr(1, asd, varSenders2(K), vbTextCompare) Then
Cells(n, 1).Value = asd
Cells(n, 2).Value = take.Items.Item(a).Recipients(b).Name
n = n + 1
End If
Next b
End If
Next a
Next K
End If
Next objitem
For Each i In fol.Items.Restrict(strFilter)
If i.Class = olMail Then
Set mi = i
'objects have been assigned and can be used to fetch emails
seemail = Worksheets("Inbox").Range("D1")
varSenders = Split(seemail, ";")
n = n + 1
For K = 0 To UBound(varSenders)
'similar logic as above
If mi.SenderEmailType = "EX" Then
seAddress = mi.Sender.GetExchangeUser().PrimarySmtpAddress
If InStr(1, seAddress, varSenders(K), vbTextCompare) Then
Cells(n, 1).Value = mi.Sender.GetExchangeUser().PrimarySmtpAddress
Cells(n, 2).Value = mi.SenderName
ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
On Error Resume Next
Range("A3:A9999").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
ElseIf mi.SenderEmailType = "SMTP" Then
seAddress = mi.SenderEmailAddress
If InStr(1, seAddress, varSenders(K), vbTextCompare) Then
Cells(n, 1).Value = mi.SenderEmailAddress
Cells(n, 2).Value = mi.SenderName
ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
On Error Resume Next
Range("A3:A9999").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
For j = mi.Recipients.Count To 1 Step -1
If (mi.Recipients.Item(j).AddressEntry.Type = "EX") Then
vcc = mi.Recipients.Item(j).Address
If InStr(1, vcc, varSenders(K), vbTextCompare) Then
Cells(n, 1).Value = mi.Recipients.Item(j).AddressEntry.GetExchangeUser.PrimarySmtpAddress
Cells(n, 2).Value = mi.Recipients.Item(j).Name
ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
On Error Resume Next
Range("A3:A9999").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
Else
vcc = mi.Recipients.Item(j).Address
If InStr(1, vcc, varSenders(K), vbTextCompare) Then
Cells(n, 1).Value = mi.Recipients.Item(j).Address
Cells(n, 2).Value = mi.Recipients.Item(j).Name
ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
On Error Resume Next
Range("A3:A9999").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
End If
Next j
Else: seAddress = ""
End If
Next K
End If
Next i
ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
On Error Resume Next
Range("A3:A9999").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Set take = Nothing
Set mi = Nothing
Application.ScreenUpdating = True
End Sub
You have to assign a value to seemail and seemail2 before using in strFilter and strFilter2.
Option Explicit
Sub GetInbox_And_SentItems()
'Early binding - requires reference to Microsoft Outlook XX.X Object Library
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim fol As Outlook.Folder
Dim folItem As Object
Dim mi As Outlook.mailItem
Dim n As Long
Dim seemail As String
Dim seAddress As String
Dim varSenders As Variant
'for sent mails
Dim b As Integer
Dim objitem As Object
Dim take As Outlook.Folder
Dim xi As Outlook.mailItem
Dim k As Long
Dim seemail2 As String
Dim seAddress2 As String
'Dim varSenders2 As Variant
Dim varReceivers As Variant
Dim strFilter As String
Dim strFilter2 As String
'screen won't refresh until this is turned true
'Application.ScreenUpdating = False
'now assigning the variables and objects of outlook into this
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.GetDefaultFolder(olFolderInbox)
Set take = ns.GetDefaultFolder(olFolderSentMail)
'Range("A3", Range("A3").End(xlDown).End(xlToRight)).Clear
Range("A3:A9999").Select
Selection.EntireRow.Delete
n = 2
varReceivers = Split(Worksheets("Inbox").Range("D1"), ";")
For k = LBound(varReceivers) To UBound(varReceivers)
seemail2 = Trim(varReceivers(k))
Debug.Print seemail2
' Note displayto not fromemail
' displayto can be a difficult value
' https://stackoverflow.com/questions/16286694/using-the-restrict-method-in-outlook-vba-to-filter-on-single-recipient-email-ad
' As far as I know there is no working toemail.
strFilter2 = "@SQL=" & Chr(34) & "urn:schemas:httpmail:displayto" & Chr(34) & " like '%" & seemail2 & "'"
Debug.Print strFilter2
Debug.Print "Items in Inbox.........:" & take.Items.Count
Debug.Print "Filtered Items in Inbox:" & take.Items.Restrict(strFilter2).Count
'this one is for sent items folder where it fetches the emails --> to <-- particular people
' there is no point searching a sent folder for sender information
For Each objitem In take.Items.Restrict(strFilter2)
If objitem.Class = olMail Then
Set xi = objitem
n = n + 1
Cells(n, 1).Value = seemail2
Cells(n, 2).Value = xi.Subject
Dim msg As String
msg = ""
For b = 1 To xi.Recipients.Count
msg = msg & xi.Recipients(b).Address & "; "
Next b
Cells(n, 3).Value = msg
End If
Next objitem
Next k
varSenders = Split(Worksheets("Inbox").Range("D1"), ";")
For k = LBound(varSenders) To UBound(varSenders)
seemail = Trim(varSenders(k))
Debug.Print seemail
strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:fromemail" & Chr(34) & " like '%" & seemail & "'"
Debug.Print strFilter
For Each folItem In fol.Items.Restrict(strFilter)
If folItem.Class = olMail Then
Set mi = folItem
'objects have been assigned and can be used to fetch emails
n = n + 1
'similar logic as above
If mi.SenderEmailType = "EX" Then
seAddress = mi.Sender.GetExchangeUser().PrimarySmtpAddress
Cells(n, 1).Value = mi.Sender.GetExchangeUser().PrimarySmtpAddress
Cells(n, 2).Value = mi.SenderName
ElseIf mi.SenderEmailType = "SMTP" Then
seAddress = mi.SenderEmailAddress
Cells(n, 1).Value = mi.SenderEmailAddress
Cells(n, 2).Value = mi.Subject
End If
End If
Next folItem
Next k
ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
'Uncomment if needed
'On Error Resume Next
Range("A3:A9999").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
Application.ScreenUpdating = True
End Sub