Question

我正在尝试让Outlook规则运行一个脚本来保存今天收到的附件，并在电子邮件的正文中包含特定的文本。我可以通过插入命令清除代码中的错误来使脚本成功运行，但这最终会导致规则失败。

我要插入明显错误的行就在Set olAttach = olItem.Attachments.item(1)之后。如果我插入Err.Clear命令，则代码可以正常工作。但是，当我没有Err.Clear命令时，代码将停止并显示“运行时错误'440'；数组索引超出范围。

如何在不清除错误的情况下使代码平稳运行？

Public Sub April26(item As Outlook.MailItem)

'
Dim olApp As Object
Dim olNS As Object
Dim myDate As Date
Dim olItems As Object
Dim olItem As Object
Dim olAttach As Object



On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
Err.Clear: On Error GoTo 0

If olApp Is Nothing Then
Set olApp = CreateObject("Outlook.Application")
Flg = True
End If

Set olNS = olApp.GetNamespace("MAPI")

Set olItems = olNS.GetDefaultFolder(olFolderInbox).Items





For Each olItem In olItems
    If olItem.ReceivedTime > Date Then
    If InStr(olItem.Body, "Michael Jordan") > 0 Then


--->    Set olAttach = olItem.Attachments.item(1)
--->    'Err.Clear: On Error GoTo 0
    If Not olAttach Is Nothing Then

    On Error GoTo Finished
    olAttach.SaveAsFile "C:\Users\Desktop\Outlook Downloads" & "\" & olAttach.FileName
    Set olAttach = Nothing
    Set olItem = Nothing

    End If
    End If
    End If
Next


Set olApp = Nothing
Set olNS = Nothing
Set olItems = Nothing

Finished:
Exit Sub

End Sub

Answer 1

所以我能够回答我的问题。我的代码的条件是保存电子邮件正文中带有“ Michael Jordan”的附件。这些电子邮件仅在清晨（12 AM到6 AM之间）发送。我知道我只发送了四封电子邮件，每封电子邮件都有一个附件，因此，一旦我总共拥有四个附件的数量，便会中断循环。

下面是我修改的代码

Public Sub April26(item As Outlook.MailItem)

'
Dim olApp As Object
Dim olNS As Object
Dim myDate As Date
Dim olItems As Object
Dim olItem As Object
Dim olAttach As Object
Dim Date1 As String
Dim Date2 As String
Dim iAttachments As Integer

Date1 = Date & " " & TimeValue("6:00:00")
Date2 = Date & " " & TimeValue("00:00:00")


On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
Err.Clear: On Error GoTo 0

If olApp Is Nothing Then
Set olApp = CreateObject("Outlook.Application")
Flg = True
End If

Set olNS = olApp.GetNamespace("MAPI")



Set olItems = olNS.GetDefaultFolder(olFolderInbox).Items



For Each olItem In olItems
    If olItem.ReceivedTime < Date1 Then
    If olItem.ReceivedTime > Date2 Then
    If InStr(olItem.Body, "Michael Jordan") > 0 Then
    'MsgBox (olItem & " " & olItem.ReceivedTime)
    iAttachments = olItem.Attachments.Count + iAttachments

    Set olAttach = olItem.Attachments.item(1)

    On Error GoTo Err_Handler
    olAttach.SaveAsFile "C:\Desktop\Outlook Downloads" & "\" & olAttach.FileName

    Set olAttach = Nothing
    Set olItem = Nothing


    If iAttachments = 4 Then Exit For
    End If
    End If
    End If
Next


    Set olAttach = Nothing
    Set olItem = Nothing
    Set olApp = Nothing
    Set olNS = Nothing
    Set olItems = Nothing



Exit Sub

Err_Handler:
    MsgBox "An unexpected error has occurred." _
        & vbCrLf & "Please note and report the following information to Darth Vader." _
        & vbCrLf & "Macro Name: April26" _
        & vbCrLf & "Error Number: " & Err.Number _
        & vbCrLf & "Error Description: " & Err.Description _
        , vbCritical, "Error!"
    Exit Sub



End Sub

Answer 2

该错误是由于没有附件。

使用On Error Resume Next会绕过预期的错误。由于预期会出现这种情况，因此您将知道如何处理它们，或者在合理的情况下忽略它们。

Option Explicit

' Extra lines for running code from applications other than Outlook removed

Public Sub April26(olItem As MailItem)

    Dim myDate As Date
    Dim olAttach As Attachment

    If olItem.ReceivedTime > Date Then

        If InStr(olItem.Body, "Michael Jordan") > 0 Then

            ' Rare beneficial use of "On Error Resume Next"
            On Error Resume Next
            ' Bypass error if there is no attachment
            Set olAttach = olItem.Attachments.item(1)
            'If there is an error olAttach remains whatever it was before
            ' In this case it is the initial value of Nothing
            ' Remove error bypass as soon as the purpose is served
            On Error GoTo 0

            If Not olAttach Is Nothing Then
                olAttach.SaveAsFile "C:\Users\Desktop\Outlook Downloads" & "\" & olAttach.fileName
                ' If this type of error handling is in a loop,
                '  reinitialize
                ' Set olAttach = Nothing
            End If

        End If
    End If

End Sub

Outlook VBA脚本有效，但设置为“邮件规则”时不起作用

2 个答案: