如何使VBA宏在Outlook中每分钟运行一次？

我将vba命令设置为Outlook左上角的按钮。此按钮将我的所有已阅读邮件移动到我的已审阅文件夹中。但是，我不希望每次阅读邮件时都要单击该按钮

有没有一种方法可以使按钮自动化？如果有，如何实现

Sub MoveInbox2Reviewed()
On Error Resume Next
Set oOutlook = CreateObject("Outlook.Application")

Set oNamespace = oOutlook.GetNamespace("MAPI")

Set oFolderSrc = oNamespace.GetDefaultFolder(olFolderInbox)

Set oFolderDst = oFolderSrc.Folders("Reviewed")

Set oFilteredItems = oFolderSrc.Items.Restrict("[UnRead] = False")

For Each oMessage In oFilteredItems

    oMessage.Move oFolderDst
Next
End Sub

---

我对以下代码进行了部分测试：

首先是演示版本：

Private Sub Application_StartupX()
Dim PauseTime, Start, demo
    demo = 100
    Do
        PauseTime = 5    ' Set duration.
        Start = Timer    ' Set start time.
        Do While Timer < Start + PauseTime
            DoEvents    ' Yield to other processes.
        Loop
        ' do your things
        demo = demo - PauseTime
    Loop While demo > 0
    MsgBox "done"
End Sub

专用子应用程序_StartupX（）
暗暂停时间、开始、演示
演示=100
做
暂停时间=5'设置持续时间。
开始=计时器“设置开始时间。
定时器<启动+暂停时间时执行
DoEvents对其他流程的产量。
环
“做你的事
demo=demo-PauseTime
演示>0时循环
MsgBox“完成”
端接头

这才是真正的问题：

Private Sub Application_Startup()
Dim PauseTime, Start
    Do
        PauseTime = 5    ' Set duration.
        Start = Timer    ' Set start time.
        Do While Timer < Start + PauseTime
            DoEvents    ' Yield to other processes.
        Loop
        ' do your things
    Loop
    ' never ends
End Sub

专用子应用程序\u启动（）
暂停一下，开始
做
暂停时间=5'设置持续时间。
开始=计时器“设置开始时间。
定时器<启动+暂停时间时执行
DoEvents对其他流程的产量。
环
“做你的事
环
"永无止境"
端接头

它使用Application.StartUp事件，它从不从该事件返回，而是为处理windows消息提供DoEvents。我没有测试真正的启动事件，但是演示版本可以工作

注：有关可能的替代方案，请参阅。我经营Office2008，Outlook不支持它；t没有此属性。

当指定集合中的项目发生更改时，会发生更改

范例

代码应该在这个OutlookSession下

Option Explicit
Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
    Dim olNs As Outlook.NameSpace
    Set olNs = Application.GetNamespace("MAPI")

    Dim Inbox  As Outlook.MAPIFolder
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items
    
End Sub

Private Sub Items_ItemChange(ByVal Item As Object)
    Dim olNs As Outlook.NameSpace
    Dim Sub_Folder  As Outlook.MAPIFolder


    Set olNs = Application.GetNamespace("MAPI")
    Set Sub_Folder = olNs.GetDefaultFolder(olFolderInbox) _
                                .Folders("Reviewed")


    If TypeOf Item Is Outlook.MailItem Then
    
        If Item.UnRead = False Then
            Debug.Print Item.Subject ' Immediate Window
            Item.Move Sub_Folder
        End If

    End If
    
End Sub