按主题搜索所有文件夹中的最新电子邮件并全部回复 [英] Search by subject for latest email in all folders and reply all
问题描述
下面的代码不执行回复所有属性,因此,我无法编辑电子邮件的正文并保持电子邮件链的对话.
The code below doesn't execute reply all property, hence, I am not able to edit the body of the email and keep the conversation of the email chain.
我认为最好的选择是使用 Application.advancesearch,因为它通过搜索所有文件夹为您提供最新的电子邮件.但我不知道如何通过 Excel 运行它.
I think the best option is to use Application.advancesearch as it gives you latest email by searching through all folders. But I do not know how to run it through Excel.
目标:
1) 在收件箱和子文件夹(多个)和已发送邮件文件夹中搜索所选主题"的最新电子邮件
2) 选择最新的邮件并回复所有
Objective:
1) Search the inbox and subfolders (multiple) and Sent items folder for the latest email for selected "Subject"
2) select the latest email and reply to all
Sub ReplyMail()
' Variables
Dim OutlookApp As Object
Dim IsOutlookCreated As Boolean
Dim sFilter As String, sSubject As String
Dim SentTime As Long
Dim IndoxTime As Long
Dim olEmailIndox As Outlook.MailItem
Dim olEmailSent As Outlook.MailItem
' Get/create outlook object
On Error Resume Next
Set OutlookApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlookApp = CreateObject("Outlook.Application")
IsOutlookCreated = True
End If
On Error GoTo 0
Set olEmailIndox = OutlookApp.CreateItem(olMailItem)
Set olEmailSent = OutlookApp.CreateItem(olMailItem)
' Restrict items
sSubject = "Subject 1"
sFilter = "[Subject] = '" & sSubject & "'"
' Main
With OutlookApp.Session.GetDefaultFolder(olFolderSentMail).Items.Restrict(sFilter)
If .Count > 0 Then
.Sort "ReceivedTime", True
Set olEmailSent = .Item(1)
SentTime = olEmailSent.SentOn
End If
End With
With OutlookApp.Session.GetDefaultFolder(olFolderInbox).Items.Restrict(sFilter)
If .Count > 0 Then
.Sort "ReceivedTime", True
Set olEmailInbox = .Item(1)
InboxTime = olEmailInbox.ReceivedTime
End If
End With
If SentTime > InboxTime Then
With olEmailSent
.ReplyAll
.Display
'.body
'.Send
End With
Else
With olEmailInbox
.ReplyAll
.Display
'.body
'.Send
End With
End If
' Quit Outlook instance if it was created by this code
If IsOutlookCreated Then
OutlookApp.Quit
Set OutlookApp = Nothing
End If
End Sub
推荐答案
我已经测试了下面的代码,即使你可以改进它,也应该让你开始.
I have tested the code below and even though you can polish it, should get you started.
如果有帮助,请告诉我并标记答案.
Let me know and mark the answer if it helps.
在 vba 模块中添加此代码:
Add in a vba module this code:
Public Sub ProcessEmails()
Dim testOutlook As Object
Dim oOutlook As clsOutlook
Dim searchRange As Range
Dim subjectCell As Range
Dim searchFolderName As String
' Start outlook if it isn't opened (credits: https://stackoverflow.com/questions/33328314/how-to-open-outlook-with-vba)
On Error Resume Next
Set testOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0
If testOutlook Is Nothing Then
Shell ("OUTLOOK")
End If
' Initialize Outlook class
Set oOutlook = New clsOutlook
' Get the outlook inbox and sent items folders path (check the scope specification here: https://docs.microsoft.com/en-us/office/vba/api/outlook.application.advancedsearch)
searchFolderName = "'" & Outlook.Session.GetDefaultFolder(olFolderInbox).FolderPath & "','" & Outlook.Session.GetDefaultFolder(olFolderSentMail).FolderPath & "'"
' Loop through excel cells with subjects
Set searchRange = ThisWorkbook.Worksheets("Sheet1").Range("A2:A4")
For Each subjectCell In searchRange
' Only to cells with actual subjects
If subjectCell.Value <> vbNullString Then
Call oOutlook.SearchAndReply(subjectCell.Value, searchFolderName, False)
End If
Next subjectCell
MsgBox "Search and reply completed"
' Clean object
Set testOutlook = Nothing
End Sub
然后添加一个类模块并命名为:clsOutlook
Then add a class module and name it: clsOutlook
在类模块中添加以下代码:
To the class module add the following code:
Option Explicit
' Credits: Based on this answer: https://stackoverflow.com/questions/31909315/advanced-search-complete-event-not-firing-in-vba
' Event handler for outlook
Dim WithEvents OutlookApp As Outlook.Application
Dim outlookSearch As Outlook.Search
Dim outlookResults As Outlook.Results
Dim searchComplete As Boolean
' Handler for Advanced search complete
Private Sub outlookApp_AdvancedSearchComplete(ByVal SearchObject As Search)
'MsgBox "The AdvancedSearchComplete Event fired."
searchComplete = True
End Sub
Sub SearchAndReply(emailSubject As String, searchFolderName As String, searchSubFolders As Boolean)
' Declare objects variables
Dim customMailItem As Outlook.MailItem
Dim searchString As String
Dim resultItem As Integer
' Variable defined at the class level
Set OutlookApp = New Outlook.Application
' Variable defined at the class level (modified by outlookApp_AdvancedSearchComplete when search is completed)
searchComplete = False
' You can look up on the internet for urn:schemas strings to make custom searches
searchString = "urn:schemas:httpmail:subject like '" & emailSubject & "'" ' Use: subject like '%" & emailSubject & "%'" if you want to include words see %
' Perform advanced search
Set outlookSearch = OutlookApp.AdvancedSearch(searchFolderName, searchString, searchSubFolders, "SearchTag")
' Wait until search is complete based on outlookApp_AdvancedSearchComplete event
While searchComplete = False
DoEvents
Wend
' Get the results
Set outlookResults = outlookSearch.Results
If outlookResults.Count = 0 Then Exit Sub
' Sort descending so you get the latest
outlookResults.Sort "[SentOn]", True
' Reply only to the latest one
resultItem = 1
' Some properties you can check from the email item for debugging purposes
On Error Resume Next
Debug.Print outlookResults.Item(resultItem).SentOn, outlookResults.Item(resultItem).ReceivedTime, outlookResults.Item(resultItem).SenderName, outlookResults.Item(resultItem).Subject
On Error GoTo 0
Set customMailItem = outlookResults.Item(resultItem).ReplyAll
' At least one reply setting is required in order to replyall to fire
customMailItem.Body = "Just a reply text " & customMailItem.Body
customMailItem.Display
End Sub
这篇关于按主题搜索所有文件夹中的最新电子邮件并全部回复的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!