AdvancedSearch和Outlook规则
AdvancedSearch和Outlook规则
提问于 2022-08-11 14:24:15
我有一个VBA脚本，需要在应用程序启动时运行，但要在处理客户端规则之后运行。为了做到这一点，我做了这里建议的事情：How can I tell when Rules have finished processing?
在脚本的其余部分运行之前，我添加了Outlook中所有规则的执行。我原以为这能解决我的问题，但事实并非如此。我的脚本只能处理收件箱中的新邮件，而不是那些有规则应用于收件箱的邮件。即使在之前添加了规则执行行之后，AdvancedSearch方法也不会提取它们。
请参阅下面的代码。谢谢你的帮助！
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回答 1
Stack Overflow用户
发布于 2022-08-11 17:40:20
您可以通过Windows函数(如SetTimer )使用内置的Windows机制在VBA中设置计时器，有关更多信息，请参见How to make safe API Timers in VBA?和Outlook VBA - Run a code every half an hour。例如：
Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerfunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Public TimerID As Long 'Need a timer ID to eventually turn off the timer. If the timer ID <> 0 then the timer is running
Public Sub ActivateTimer(ByVal nMinutes As Long)
nMinutes = nMinutes * 1000 * 60 'The SetTimer call accepts milliseconds, so convert to minutes
If TimerID <> 0 Then Call DeactivateTimer 'Check to see if timer is running before call to SetTimer
TimerID = SetTimer(0, 0, nMinutes, AddressOf TriggerTimer)
If TimerID = 0 Then
MsgBox "The timer failed to activate."
End If
End Sub
Public Sub DeactivateTimer()
Dim lSuccess As Long
lSuccess = KillTimer(0, TimerID)
If lSuccess = 0 Then
MsgBox "The timer failed to deactivate."
Else
TimerID = 0
End If
End Sub
Public Sub TriggerTimer(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idevent As Long, ByVal Systime As Long)
MsgBox "The TriggerTimer function has been automatically called!"
End Sub页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/73322352
复制相关文章
相似问题
腾讯云开发者
