Используя Outlook 2016, я попытался найти последнее письмо, отправленное или полученное с указанного c адреса электронной почты, и сохранить его копию в указанной папке c.
Я разработал некоторый код, но мне кажется, У меня проблема с сортировкой и выбором правильных запрещенных предметов. После сортировки по дате код не выбирает последнее письмо. Он последовательно возвращает одно и то же письмо, если запускает код несколько раз, но определенно не возвращает последнее письмо.
Ниже приведена функция, которую я создал. Надеюсь, кто-нибудь сможет помочь. Заранее спасибо.
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 & "\Desktop\Email-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
РЕДАКТОР 20 АПРЕЛЯ 2020
В дополнение к совету Дмитрия я изменил код, как показано ниже, но, похоже, он НЕ работает на Отправленные вещи. У меня есть 2 проблемы, надеюсь, кто-нибудь может помочь.
- Он не перехватывает самую новую / последнюю электронную почту. Я подозреваю, что это как-то связано с фильтром, используемым для поиска адреса электронной почты получателя. Может ли кто-нибудь помочь улучшить фильтр, чтобы он мог искать адрес электронной почты получателя во всех полях «Кому», CC и B CC?
- Если у меня есть длинный список адресов электронной почты, которые необходимо найдено, пропущено / пропущено несколько адресов электронной почты (похоже, функция поиска не возвращает никакого результата для некоторых адресов электронной почты). Целевые электронные письма есть, но код не может получить соответствующее электронное письмо.
Ниже приведен измененный код:
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 & "\Desktop\Email-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