【发布时间】：2019-01-01 14:45:33
【问题描述】：
很抱歉，我仍然是一个自学成才的业余爱好者：但我的项目是自动化一些任务，在此期间我可以按发件人和主题过滤 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
【问题讨论】：
标签： vba sorting outlook filtering