很抱歉发了这么长的帖子，我仍然是一个自学成才的业余爱好者：但我的项目是自动化一些任务，在这些任务中，我可以按发件人和主题过滤outlook邮件，并将它们发送到特定的文件夹。(由于某些原因，我无法使用内置的Outlook筛选器(。下面的代码运行良好，但宏访问的某些框位于另一个国家/地区的服务器上，因此某些操作需要很长时间。从本质上讲，我的代码循环浏览要筛选的电子邮件地址列表和潜在的主题行。它检查每一封电子邮件，比较发件人姓名和主题，然后确定发送到哪个文件夹，并移动它
我的问题是，如何通过使用更聪明的代码或减少操作总数来提高效率？有没有比一比一更有效的方法来搜索所有电子邮件？有没有可能把它们都分块移动，而不是一个接一个地移动？如果有人能帮忙，我将不胜感激。我的代码如下(我意识到有一些不必要的行，但我将其中一些用于多个项目(。非常感谢！
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
编辑------------------------------
这是我的新代码。
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
永远不要循环浏览文件夹中的所有项目，使用Items.Find/FindNext或Items.Res限制。
对PR_SENT_REPRESENTING_EMAIL_ADDRESS(DASL名称http://schemas.microsoft.com/mapi/proptag/0x0065001F(和PidTagSenderSmtpAddress(DASL名http://schemas.microsoft.com/mapi/proptag/0x5D01001F(创建一个限制，前者将覆盖"SMTP"发件人，后者将针对EX发件人。