使用Outlook 2016，我试图找到发送到特定电子邮件地址或从特定电子邮件地址收到的最新电子邮件，并将其副本保存到特定文件夹。
我已经开发了一些代码，但我认为我在排序和挑选正确的受限项目方面有问题。一旦按日期排序，代码就不会选择最新的电子邮件。如果多次运行代码，它会始终返回相同的电子邮件，但肯定不会返回最新的电子邮件。
下面是我创建的函数。希望有人能帮忙。提前谢谢。
Sub Get_The_Emails(intTarget As Integer)
Dim oInboxFolder As Outlook.folder, oSentFolder As Outlook.folder
Dim tFolder As Outlook.folder, sFolder As Outlook.folder
Dim oNS As Outlook.NameSpace
Dim oInboxItems As Outlook.Items, oSentItems As Outlook.Items, colItems As Outlook.Items
Dim oFilteredInboxItems As Outlook.Items, oFilteredSentItems As Outlook.Items, oFilteredItems As Outlook.Items
Dim oReceivedItem As Outlook.MailItem, oSentItem As Outlook.MailItem, oItem As Outlook.MailItem
Dim strFolder As String
Dim strSentFilter As String, strReceivedFilter As String
Dim intFolder As Integer, intMode As Integer, intSource As Integer
Dim theReceivedTime As Date, theSentTime As Date
Dim inputFile As String
Dim inputNum As Integer, i As Integer
Dim strEnviro As String, strContent As String
Dim varList As Variant
strEnviro = CStr(Environ("USERPROFILE"))
inputFile = strEnviro & "DesktopEmail-List.txt"
If Dir(inputFile, vbDirectory) = "" Then
MsgBox "File: " & inputFile & " could not be found", vbCritical, "Error"
Exit Sub
Else
CleanList inputFile
DoEvents
End If
inputNum = FreeFile
Open inputFile For Input As inputNum
strContent = Input(LOF(inputNum), inputNum)
Close inputNum
If Len(strContent) < 6 Then
MsgBox "Invalid email address list", vbCritical, "Error"
Exit Sub
Else
varList = Split(strContent, vbNewLine)
End If
Set oNS = Application.GetNamespace("MAPI")
Set oInboxFolder = oNS.Session.GetDefaultFolder(olFolderInbox)
Set oInboxItems = oInboxFolder.Items
Set oSentFolder = oNS.Session.GetDefaultFolder(olFolderSentMail)
Set oSentItems = oSentFolder.Items
intFolder = intTarget
Select Case intFolder
Case 1: strFolder = "1. Latest"
Case 2: strFolder = "2. Received"
Case 3: strFolder = "3. Sent"
End Select
On Error Resume Next
Set tFolder = oNS.Session.GetDefaultFolder(olFolderInbox).Parent.Folders(strFolder)
If Err <> 0 Then
Err.Clear
Set tFolder = oNS.Session.GetDefaultFolder(olFolderInbox).Parent.Folders.Add(strFolder)
End If
On Error GoTo 0
intMode = intTarget
Select Case intFolder
Case 1: For i = LBound(varList) To UBound(varList)
strSentFilter = "@SQL=" & "urn:schemas:httpmail:displayto" & _
" Like '%" & CStr(varList(i)) & "%' Or " & _
"urn:schemas:httpmail:displaycc" & _
" Like '%" & CStr(varList(i)) & "%' Or " & _
"urn:schemas:httpmail:displaybcc" & _
" Like '%" & CStr(varList(i)) & "%'"
Set oFilteredInboxItems = oInboxItems.Restrict("[SenderEmailAddress] = '" & CStr(varList(i)) & "'")
With oFilteredInboxItems
If .Count > 0 Then
oFilteredInboxItems.Sort "[ReceivedTime]", True
theReceivedTime = oFilteredInboxItems(1).ReceivedTime
End If
End With
'Set oFilteredSentItems = oSentItems.Restrict("[To] = '" & CStr(varList(i)) & "'")
Set oFilteredSentItems = oSentItems.Restrict(strSentFilter)
With oFilteredSentItems
If .Count > 0 Then
oFilteredSentItems.Sort "[SentOn]", True
theSentTime = oFilteredSentItems(1).SentOn
End If
End With
If oFilteredInboxItems.Count > 0 And oFilteredSentItems.Count = 0 Then
Set oItem = oFilteredInboxItems(1)
End If
If oFilteredInboxItems.Count = 0 And oFilteredSentItems.Count > 0 Then
Set oItem = oFilteredSentItems(1)
End If
If oFilteredInboxItems.Count > 0 And oFilteredSentItems.Count > 0 Then
If theReceivedTime > theSentTime Then
Set oItem = oFilteredInboxItems(1)
Else
Set oItem = oFilteredSentItems(1)
End If
End If
oItem.Copy
oItem.Move tFolder
Debug.Print oFilteredInboxItems(1).Subject, theReceivedTime, oFilteredSentItems(1).Subject, theSentTime
Set oFilteredInboxItems = Nothing: Set oFilteredSentItems = Nothing: Set oFilteredItems = Nothing
Set oReceivedItem = Nothing: Set oSentItem = Nothing: Set oItem = Nothing
Next
Case 2: For i = LBound(varList) To UBound(varList)
Set oFilteredInboxItems = oInboxItems.Restrict("[SenderEmailAddress] = '" & CStr(varList(i)) & "'")
With oFilteredInboxItems
If .Count > 0 Then
oFilteredInboxItems.Sort "[ReceivedTime]", True
theReceivedTime = oFilteredInboxItems(1).ReceivedTime
Set oReceivedItem = oFilteredInboxItems(1).Copy
oReceivedItem.Move tFolder
Debug.Print CStr(varList(i)), oReceivedItem.Subject, theReceivedTime
End If
End With
Set oFilteredInboxItems = Nothing: Set oFilteredSentItems = Nothing: Set oFilteredItems = Nothing
Set oReceivedItem = Nothing: Set oSentItem = Nothing: Set oItem = Nothing
Next
Case 3: For i = LBound(varList) To UBound(varList)
strSentFilter = "@SQL=" & "urn:schemas:httpmail:displayto" & _
" Like '%" & CStr(varList(i)) & "%' Or " & _
"urn:schemas:httpmail:displaycc" & _
" Like '%" & CStr(varList(i)) & "%' Or " & _
"urn:schemas:httpmail:displaybcc" & _
" Like '%" & CStr(varList(i)) & "%'"
'Set oFilteredSentItems = oSentItems.Restrict("[To] = '" & CStr(varList(i)) & "'")
Set oFilteredSentItems = oSentItems.Restrict(strSentFilter)
With oFilteredSentItems
Debug.Print i, CStr(varList(i)), .Count
If .Count > 0 Then
oFilteredSentItems.Sort "[SentOn]", True
theSentTime = oFilteredSentItems(1).SentOn
Set oSentItem = oFilteredSentItems(1).Copy
oSentItem.Move tFolder
Debug.Print i, CStr(varList(i)), oSentItem.Subject, theSentTime
End If
End With
Set oFilteredInboxItems = Nothing: Set oFilteredSentItems = Nothing: Set oFilteredItems = Nothing
Set oReceivedItem = Nothing: Set oSentItem = Nothing: Set oItem = Nothing
Next
End Select
End Sub
编辑于2020年4月20日
根据德米特里的建议，我修改了下面的代码，但它似乎不适用于已发送邮件。我有两个问题，希望有人能帮忙。
- 它不会捕获最新/最新的电子邮件。我怀疑这与用于查找收件人电子邮件地址的过滤器有关。有人能帮助改进过滤器吗？这样它就可以在所有"收件人"、"抄送"one_answers"密件抄送"字段中查找收件人的电子邮件地址
- 如果我有一长串要查找的电子邮件地址，它会错过/跳过一些电子邮件地址(查找功能似乎不会返回某些电子邮件地址的任何结果(。目标电子邮件在那里，但代码无法提取相应的电子邮件
以下是修改后的代码：
Sub Get_The_Emails(intTarget As Integer)
Dim oInboxFolder As Outlook.folder, oSentFolder As Outlook.folder
Dim tFolder As Outlook.folder, sFolder As Outlook.folder
Dim oNS As Outlook.NameSpace
Dim oInboxItems As Outlook.Items, oSentItems As Outlook.Items, colItems As Outlook.Items
Dim oFilteredInboxItems As Outlook.Items, oFilteredSentItems As Outlook.Items, oFilteredItems As Outlook.Items
Dim oReceivedItem As Outlook.MailItem, oSentItem As Outlook.MailItem, oItem As Outlook.MailItem
Dim strFolder As String
Dim strSentFilter As String, strReceivedFilter As String
Dim intFolder As Integer, intMode As Integer, intSource As Integer
Dim theReceivedTime As Date, theSentTime As Date
Dim inputFile As String
Dim inputNum As Integer, i As Integer
Dim strEnviro As String, strContent As String
Dim varList As Variant
strEnviro = CStr(Environ("USERPROFILE"))
inputFile = strEnviro & "DesktopEmail-List.txt"
If Dir(inputFile, vbDirectory) = "" Then
MsgBox "File: " & inputFile & " could not be found", vbCritical, "Error"
Exit Sub
Else
CleanList inputFile
DoEvents
End If
inputNum = FreeFile
Open inputFile For Input As inputNum
strContent = Input(LOF(inputNum), inputNum)
Close inputNum
If Len(strContent) < 6 Then
MsgBox "Invalid email address list", vbCritical, "Error"
Exit Sub
Else
varList = Split(strContent, vbNewLine)
End If
Set oNS = Application.GetNamespace("MAPI")
Set oInboxFolder = oNS.Session.GetDefaultFolder(olFolderInbox)
Set oInboxItems = oInboxFolder.Items
Set oSentFolder = oNS.Session.GetDefaultFolder(olFolderSentMail)
Set oSentItems = oSentFolder.Items
intFolder = intTarget
Select Case intFolder
Case 1: strFolder = "1. Latest"
Case 2: strFolder = "2. Received"
Case 3: strFolder = "3. Sent"
End Select
On Error Resume Next
Set tFolder = oNS.Session.GetDefaultFolder(olFolderInbox).Parent.Folders(strFolder)
If Err <> 0 Then
Err.Clear
Set tFolder = oNS.Session.GetDefaultFolder(olFolderInbox).Parent.Folders.Add(strFolder)
End If
On Error GoTo 0
intMode = intTarget
Select Case intFolder
Case 1
For i = LBound(varList) To UBound(varList)
strSentFilter = "@SQL=" & "urn:schemas:httpmail:displayto" & _
" Like '%" & CStr(varList(i)) & "%' Or " & _
"urn:schemas:httpmail:displaycc" & _
" Like '%" & CStr(varList(i)) & "%' Or " & _
"urn:schemas:httpmail:displaybcc" & _
" Like '%" & CStr(varList(i)) & "%'"
oInboxItems.Sort "[ReceivedTime]", True
Set oReceivedItem = oInboxItems.Find("[SenderEmailAddress] = '" & CStr(varList(i)) & "'")
If Not oReceivedItem Is Nothing Then
theReceivedTime = oReceivedItem.ReceivedTime
End If
oSentItems.Sort "[SentOn]", True
Set oSentItem = oSentItems.Find(strSentFilter)
If Not oSentItem Is Nothing Then
theSentTime = oSentItem.SentOn
End If
If Not oReceivedItem Is Nothing And oSentItem Is Nothing Then
Set oItem = oReceivedItem
End If
If oReceivedItem Is Nothing And Not oSentItem Is Nothing Then
Set oItem = oSentItem
End If
If Not oReceivedItem Is Nothing And Not oSentItem Is Nothing Then
If theReceivedTime > theSentTime Then
Set oItem = oReceivedItem
Else
Set oItem = oSentItem
End If
End If
oItem.Copy
oItem.Move tFolder
If Not oReceivedItem Is Nothing And Not oSentItem Is Nothing Then
Debug.Print "*** 1. Latest from/to: " & CStr(varList(i)) & " ***"
Debug.Print , "Received:" & vbTab, oReceivedItem.Subject, theReceivedTime
Debug.Print , "Sent:" & vbTab, oSentItem.Subject, theSentTime
Debug.Print "=================================================="
End If
Set oReceivedItem = Nothing: Set oSentItem = Nothing: Set oItem = Nothing
Next
Case 2
For i = LBound(varList) To UBound(varList)
oInboxItems.Sort "[ReceivedTime]", True
Set oReceivedItem = oInboxItems.Find("[SenderEmailAddress] = '" & CStr(varList(i)) & "'")
If Not oReceivedItem Is Nothing Then
theReceivedTime = oReceivedItem.ReceivedTime
oReceivedItem.Copy
oReceivedItem.Move tFolder
Debug.Print "*** 2. Received from: " & CStr(varList(i)) & " ***"
Debug.Print , oReceivedItem.Subject, theReceivedTime
Debug.Print "================================================="
End If
Set oReceivedItem = Nothing: Set oSentItem = Nothing: Set oItem = Nothing
Next
Case 3
For i = LBound(varList) To UBound(varList)
strSentFilter = "@SQL=" & "urn:schemas:httpmail:displayto" & _
" Like '%" & CStr(varList(i)) & "%' Or " & _
"urn:schemas:httpmail:displaycc" & _
" Like '%" & CStr(varList(i)) & "%' Or " & _
"urn:schemas:httpmail:displaybcc" & _
" Like '%" & CStr(varList(i)) & "%'"
oSentItems.Sort "[SentOn]", True
Set oSentItem = oSentItems.Find(strSentFilter)
If Not oSentItem Is Nothing Then
theSentTime = oSentItem.SentOn
oSentItem.Copy
oSentItem.Move tFolder
Debug.Print "*** 3. Sent to: " & CStr(varList(i)) & " ***"
Debug.Print , oSentItem.Subject, theSentTime
Debug.Print "==========================================="
End If
Set oReceivedItem = Nothing: Set oSentItem = Nothing: Set oItem = Nothing
Next
End Select
End Sub
绝对没有理由使用Restrict，因为您只想要返回集合中的一个项。首先对项目集合进行排序(Items.Sort(，然后使用Items.Find查找匹配项。
似乎没有完成对新过滤器"strSentFilter"的转换。
更换旧的过滤器后，这似乎是"找到发送到特定电子邮件地址或从特定电子邮件地址接收的最新电子邮件，并将其副本保存到特定文件夹。">
Option Explicit
Private Sub Get_The_Emails_TEST()
' 1. Latest
' 2. Received
' 3. Sent
Get_The_Emails 1
End Sub
Sub Get_The_Emails(intTarget As Long)
Dim oInboxFolder As Folder, oSentFolder As Folder
Dim tFolder As Folder, sFolder As Folder
Dim oInboxItems As items, oSentItems As items
Dim oFilteredInboxItems As items, oFilteredSentItems As items
Dim oReceivedItem As MailItem, oSentItem As MailItem, oItem As MailItem
Dim strFolder As String
Dim strSentFilter As String, strReceivedFilter As String
Dim intFolder As Long, intMode As Long, intSource As Long
Dim theReceivedTime As Date, theSentTime As Date
Dim inputNum As Long, i As Long
Dim strEnviro As String, strContent As String
'Dim varList As Variant
Dim varList() As Variant
' for testing without "Email-List.txt"
varList() = Array("address1@somewhere.com", "address2@somewhere.com", "noAddress@nowhere.com")
'strEnviro = CStr(Environ("USERPROFILE"))
'inputFile = strEnviro & "DesktopEmail-List.txt"
'If dir(inputFile, vbDirectory) = "" Then
' MsgBox "File: " & inputFile & " could not be found", vbCritical, "Error"
' Exit Sub
'Else
' CleanList inputFile
' DoEvents
'End If
'inputNum = FreeFile
'Open inputFile For Input As inputNum
' strContent = Input(LOF(inputNum), inputNum)
'Close inputNum
'If Len(strContent) < 6 Then
' MsgBox "Invalid email address list", vbCritical, "Error"
' Exit Sub
'Else
' varList = Split(strContent, vbNewLine)
'End If
Set oInboxFolder = Session.GetDefaultFolder(olFolderInbox)
Set oInboxItems = oInboxFolder.items
Set oSentFolder = Session.GetDefaultFolder(olFolderSentMail)
Set oSentItems = oSentFolder.items
intFolder = intTarget
Select Case intFolder
Case 1: strFolder = "1. Latest"
Case 2: strFolder = "2. Received"
Case 3: strFolder = "3. Sent"
End Select
On Error Resume Next
Set tFolder = Session.GetDefaultFolder(olFolderInbox).Parent.folders(strFolder)
If Err <> 0 Then
Err.Clear
Set tFolder = Session.GetDefaultFolder(olFolderInbox).Parent.folders.Add(strFolder)
End If
On Error GoTo 0
intMode = intTarget
Select Case intFolder
Case 1: For i = LBound(varList) To UBound(varList)
Debug.Print
Debug.Print i, CStr(varList(i))
strSentFilter = "@SQL=" & "urn:schemas:httpmail:displayto" & _
" Like '%" & CStr(varList(i)) & "%' Or " & _
"urn:schemas:httpmail:displaycc" & _
" Like '%" & CStr(varList(i)) & "%' Or " & _
"urn:schemas:httpmail:displaybcc" & _
" Like '%" & CStr(varList(i)) & "%'"
'Set oFilteredInboxItems = oInboxItems.Restrict("[SenderEmailAddress] = '" & CStr(varList(i)) & "'")
Set oFilteredInboxItems = oInboxItems.Restrict(strSentFilter)
With oFilteredInboxItems
If .count > 0 Then
oFilteredInboxItems.sort "[ReceivedTime]", True
theReceivedTime = oFilteredInboxItems(1).ReceivedTime
Debug.Print "Inbox:"
Debug.Print theReceivedTime & " " & oFilteredInboxItems(1).Subject
End If
End With
'Set oFilteredSentItems = oSentItems.Restrict("[To] = '" & CStr(varList(i)) & "'")
Set oFilteredSentItems = oSentItems.Restrict(strSentFilter)
With oFilteredSentItems
If .count > 0 Then
oFilteredSentItems.sort "[SentOn]", True
theSentTime = oFilteredSentItems(1).SentOn
Debug.Print "Sent folder:"
Debug.Print theSentTime & " " & oFilteredSentItems(1).Subject
End If
End With
If oFilteredInboxItems.count > 0 And oFilteredSentItems.count = 0 Then
Set oItem = oFilteredInboxItems(1)
Debug.Print "Inbox:"
End If
If oFilteredInboxItems.count = 0 And oFilteredSentItems.count > 0 Then
Set oItem = oFilteredSentItems(1)
Debug.Print "Sent folder:"
End If
If oFilteredInboxItems.count > 0 And oFilteredSentItems.count > 0 Then
If theReceivedTime > theSentTime Then
Set oItem = oFilteredInboxItems(1)
Debug.Print "Inbox item chosen:"
Else
Set oItem = oFilteredSentItems(1)
Debug.Print "Sent folder item chosen:"
End If
End If
If Not oItem Is Nothing Then
oItem.Copy
oItem.Move tFolder
Debug.Print oItem.Subject
Else
Debug.Print "No item found."
End If
Set oFilteredInboxItems = Nothing: Set oFilteredSentItems = Nothing
Set oReceivedItem = Nothing: Set oSentItem = Nothing: Set oItem = Nothing
Next
Case 2: For i = LBound(varList) To UBound(varList)
Debug.Print
Debug.Print i, CStr(varList(i))
strSentFilter = "@SQL=" & "urn:schemas:httpmail:displayto" & _
" Like '%" & CStr(varList(i)) & "%' Or " & _
"urn:schemas:httpmail:displaycc" & _
" Like '%" & CStr(varList(i)) & "%' Or " & _
"urn:schemas:httpmail:displaybcc" & _
" Like '%" & CStr(varList(i)) & "%'"
'Set oFilteredInboxItems = oInboxItems.Restrict("[SenderEmailAddress] = '" & CStr(varList(i)) & "'")
Set oFilteredInboxItems = oInboxItems.Restrict(strSentFilter)
With oFilteredInboxItems
If .count > 0 Then
oFilteredInboxItems.sort "[ReceivedTime]", True
theReceivedTime = oFilteredInboxItems(1).ReceivedTime
Set oReceivedItem = oFilteredInboxItems(1).Copy
oReceivedItem.Move tFolder
Debug.Print "Inbox:"
Debug.Print theReceivedTime & " " & oFilteredInboxItems(1).Subject
Else
Debug.Print "No item found."
End If
End With
Set oFilteredInboxItems = Nothing: Set oFilteredSentItems = Nothing
Set oReceivedItem = Nothing: Set oSentItem = Nothing: Set oItem = Nothing
Next
Case 3: For i = LBound(varList) To UBound(varList)
Debug.Print
Debug.Print i, CStr(varList(i))
strSentFilter = "@SQL=" & "urn:schemas:httpmail:displayto" & _
" Like '%" & CStr(varList(i)) & "%' Or " & _
"urn:schemas:httpmail:displaycc" & _
" Like '%" & CStr(varList(i)) & "%' Or " & _
"urn:schemas:httpmail:displaybcc" & _
" Like '%" & CStr(varList(i)) & "%'"
'Set oFilteredSentItems = oSentItems.Restrict("[To] = '" & CStr(varList(i)) & "'")
Set oFilteredSentItems = oSentItems.Restrict(strSentFilter)
With oFilteredSentItems
If .count > 0 Then
oFilteredSentItems.sort "[SentOn]", True
theSentTime = oFilteredSentItems(1).SentOn
Set oSentItem = oFilteredSentItems(1).Copy
oSentItem.Move tFolder
Debug.Print "Sent folder:"
Debug.Print theSentTime & " " & oFilteredSentItems(1).Subject
Else
Debug.Print "No item found."
End If
End With
Set oFilteredInboxItems = Nothing: Set oFilteredSentItems = Nothing
Set oReceivedItem = Nothing: Set oSentItem = Nothing: Set oItem = Nothing
Next
End Select
End Sub