所以很明顯，這個宏從收件箱中獲取特定的電子郵件地址以及從 cc、bcc 發送的郵件地址，
問題是它需要很多時間，我的意思是如果一個人有 2k 封電子郵件，他可能需要等待 3到4小時。
檢查一些資源如何使代碼更快我了解了通過 DASL 過濾器應用時的限制功能和限制回圈中的專案數。我應用了相同的方法，但結果仍然相同，并且獲取速度仍然很慢。
作為 VBA 的新手，我對優化一無所知，仍在學習。
任何其他來源或方法可以使獲取和執行更快？
代碼供參考
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
uj5u.com熱心網友回復：
在使用 in和之前，您必須為 and 分配一個seemail值。seemail2strFilterstrFilter2
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
uj5u.com熱心網友回復：
所有從外回圈接觸電子郵件的代碼都應該從內回圈中取出。例如像這樣的線
seAddress2 = xi.Sender.GetExchangeUser.PrimarySmtpAddress
沒有業務處于內部回圈中。
我也不會呼叫RemoveDuplicates回圈的每一步。
此外，發件人很可能不是唯一的 -SenderEmailAddress使用MAPIFolder.GetTable一次檢索所有發件人地址 ()并構建 EX 型別地址與 SMTP 地址 ( GetExchangeUser.PrimarySmtpAddress) 的字典，每個唯一地址只計算一次，一遍又一遍地檢索它。
轉載請註明出處，本文鏈接：https://www.uj5u.com/net/451567.html
下一篇：Excel2007，VBA：零售6.5.1057——Application.WorksheetFunction.Average()