Outlook VBA出现Run-time error 424，请求排查代码问题

核心错误原因（触发Run-time error 424） #

• rvFolder变量未声明也未赋值：代码直接调用rvFolder.Folders("Inbox")，但该变量从未定义或通过MAPI命名空间获取对应文件夹对象，系统无法识别此对象导致报错。
• 重复赋值rvItems：连续两次给WithEvents类型的rvItems赋值，后一次会覆盖前一次，且WithEvents变量只能绑定一个Items集合，逻辑完全错误。

其他代码问题 #

• rvInbox变量未声明：代码中Set rvInbox = rvNS.GetDefaultFolder(olFolderInbox).Items未提前声明变量，属于隐式变量，易引发未知问题。
• 事件处理位置错误：rvItems_ItemAdd是WithEvents变量对应的事件，必须和rvItems定义在同一模块（即ThisOutlookSession），放在普通模块不会触发事件。
• 保存路径存在冗余空格："C:\Users\BG-TRADE-005\OneDrive - alpiq.com\Desktop\Schedule\Mail_Temp \Download"中Mail_Temp后多了一个空格，会导致路径识别失败。
• 文件夹定位逻辑缺失：若Test是收件箱的子文件夹，需通过收件箱对象获取，而非凭空使用未定义的rvFolder。

修复后的完整代码 #

ThisOutlookSession部分 #

Private WithEvents rvInboxItems As Outlook.Items
Private WithEvents rvTestFolderItems As Outlook.Items ' 如需同时监听Test文件夹，定义第二个WithEvents变量

Private Sub Application_Startup()
    Dim rvNS As Outlook.NameSpace
    Dim inboxFolder As Outlook.Folder
    Dim testFolder As Outlook.Folder
    
    Set rvNS = Outlook.Application.GetNamespace("MAPI")
    Set inboxFolder = rvNS.GetDefaultFolder(olFolderInbox)
    Set rvInboxItems = inboxFolder.Items
    
    ' 获取Test文件夹：假设是收件箱的子文件夹
    On Error Resume Next ' 避免Test文件夹不存在时触发报错
    Set testFolder = inboxFolder.Folders("Test")
    On Error GoTo 0
    If Not testFolder Is Nothing Then
        Set rvTestFolderItems = testFolder.Items
    End If
End Sub

' 收件箱的ItemAdd事件处理
Private Sub rvInboxItems_ItemAdd(ByVal item As Object)
    SaveAttachments item
End Sub

' Test文件夹的ItemAdd事件处理
Private Sub rvTestFolderItems_ItemAdd(ByVal item As Object)
    SaveAttachments item
End Sub

' 通用保存附件逻辑
Private Sub SaveAttachments(ByVal item As Object)
    Dim rvMail As Outlook.MailItem
    Dim rvAtt As Outlook.Attachment
    Dim savePath As String
    
    savePath = "C:\Users\BG-TRADE-005\OneDrive - alpiq.com\Desktop\Schedule\Mail_Temp\Download\" ' 修正空格，添加末尾斜杠
    
    If TypeName(item) = "MailItem" Then
        Set rvMail = item
        For Each rvAtt In rvMail.Attachments
            ' 可在此添加附件过滤条件，比如仅下载指定后缀的文件
            rvAtt.SaveAsFile savePath & rvAtt.FileName
        Next rvAtt
        Set rvMail = Nothing
    End If
End Sub

额外说明 #

1. 代码生效需重启Outlook，因为Application_Startup仅在Outlook启动时触发。
2. 若Test文件夹不是收件箱的子文件夹，需修改定位方式，例如通过rvNS.Folders("你的邮箱账户名").Folders("Test")获取。
3. 如需过滤特定附件，可在保存逻辑中添加判断，比如仅下载Excel或PDF文件：

   If LCase(Right(rvAtt.FileName, 4)) = ".xlsx" Or LCase(Right(rvAtt.FileName, 4)) = ".pdf" Then
       rvAtt.SaveAsFile savePath & rvAtt.FileName
   End If
   

内容的提问来源于stack exchange，提问作者Harati