Outlook启动后客户端规则执行完毕时运行VBA脚本,AdvancedSearch失效
问题:Outlook启动后规则执行完毕仍无法捕获被规则移动的邮件
我需要一个在Outlook应用启动后、客户端规则处理完毕后运行的VBA脚本。我尝试在脚本运行前添加执行所有Outlook规则的代码,但问题并未解决——脚本仅能处理收件箱中的新邮件,被规则处理过的邮件无法被AdvancedSearch方法捕获,即使提前执行了规则代码也无效。
以下是相关VBA代码:
Option Explicit Public blnSearchComp As Boolean Private Sub Application_AdvancedSearchComplete(ByVal SearchObject As Search) Debug.Print "The AdvancedSearchComplete Event fired" If SearchObject.Tag = "Process_New_Items" Then 'm_SearchComplete = True` ' Use Option Explicit. blnSearchComp = True End If End Sub Private Sub Application_Startup() Dim dmi As MailItem Dim timeFol As Folder Dim timeFilter As String Dim lastclose As String Dim utcdate As Date Dim strFilter As String Dim i As Object Dim strScope As String Dim SearchObject As Search '---------------------------------------------------------------------- Dim olRules As Outlook.Rules Dim myRule As Outlook.Rule Set olRules = Application.Session.DefaultStore.GetRules() For Each myRule In olRules ' Rules we want to run myRule.Execute Next '---------------------------------------------------------------------- Set dmi = CreateItem(olMailItem) Set timeFol = Session.GetDefaultFolder(olFolderNotes) timeFilter = "[Subject] = 'App Close Time'" For Each i In timeFol.Items.Restrict(timeFilter) lastclose = i.CreationTime Next i Debug.Print lastclose utcdate = dmi.PropertyAccessor.LocalTimeToUTC(lastclose) 'strFilter = "@SQL=""urn:schemas:httpmail:datereceived"" >= '&" & Format(utcdate, "dd mmm yyyy hh:mm") & "'" strFilter = "urn:schemas:httpmail:datereceived >= " & "'" & utcdate & "'" Debug.Print strFilter 'strScope = "'" & Session.Folders(1).Folders("Inbox") & "'" Debug.Print strScope 'strScope = "'" & Session.GetDefaultFolder(olFolderInbox) & "'" Debug.Print strScope strScope = "'Inbox'" Debug.Print strScope 'strScope = "'" & Application.Session.GetDefaultFolder(olFolderInbox).FolderPath & "'" 'Sleep (20) Set SearchObject = AdvancedSearch(Scope:=strScope, Filter:=strFilter, SearchSubFolders:=True, Tag:="Process_New_Items") blnSearchComp = False ' Otherwise remains True. ' Search would work once until Outlook restarted. While blnSearchComp = False DoEvents ' Code should be in a class module such as ThisOutlookSession Debug.Print "Wait a few seconds. Ctrl + Break if needed." Wend Debug.Print "SearchObject.results.count: " & SearchObject.Results.Count For Each i In SearchObject.Results If TypeName(i) = "MailItem" Then Process_MailItem i Debug.Print i.ReceivedTime, i.Subject Else: End If Next i End Sub
内容的提问来源于stack exchange,提问作者Adam
相关产品推荐
相关产品推荐

