在Outlook中运行VBA脚本时出现运行时错误'-2147221241(80040107) [英] Run-time error '-2147221241 (80040107) while running VBA script in Outlook

问题描述

我在Outlook中运行一个VBA脚本，该脚本应该将具有特定主题的传入电子邮件移动到Outlook中的子文件夹，然后将这些电子邮件导出到TXT文件中.

I have a VBA script running in Outlook that is supposed to move incoming emails with a specific subject to a subfolder within Outlook, and then export those emails to TXT files.

这在大多数情况下都有效，但是在导出几封电子邮件后，出现以下消息:运行时错误'-2147221241(80040107)':操作失败."弹出.我对其进行了调试，并突出显示了代码行:

This is working for the most part, but after several emails are exported the message: "Run-time error '-2147221241 (80040107)': The Operation failed." pops up. I debugged it and it is highlighting the line of code:

RevdDate = Item.ReceivedTime 

出现此错误后，我可以重新启动Outlook，它通常将导出其余电子邮件，而不会出现任何问题.但是，我们需要将其完全自动化，因此我需要消除此错误.

Once this error appears I can restart Outlook and it will usually export the remainder of the emails with no issues. However we are needing this to be completely automated so I need to eliminate this error.

下面是完整的代码:

    Option Explicit
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
    Dim olNs As Outlook.NameSpace
    Dim Inbox  As Outlook.MAPIFolder

    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
    If TypeOf Item Is Outlook.MailItem Then
        SaveMailAsFile Item ' call sub
    End If
End Sub
Public Sub SaveMailAsFile(ByVal Item As Object)
    Dim olNs As Outlook.NameSpace
    Dim Inbox As Outlook.MAPIFolder
    Dim SubFolder As Outlook.MAPIFolder
    Dim Items As Outlook.Items
    Dim ItemSubject As String
    Dim NewName As String
    Dim RevdDate As Date
    Dim Path As String
    Dim Ext As String
    Dim i As Long

    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items.Restrict("[Subject] = 'VVAnalyze Results'")

    Path = Environ("ltvstatus") & "C:\Users\ltvstatus\Desktop\Backup Reports\"
    ItemSubject = Item.Subject
    RevdDate = Item.ReceivedTime
    Ext = "txt"

    For i = Items.Count To 1 Step -1
        Set Item = Items.Item(i)

        DoEvents

        If Item.Class = olMail Then
            Debug.Print Item.Subject ' Immediate Window
            Set SubFolder = Inbox.Folders("Reports") ' <--- Update Fldr Name

            ItemSubject = Format(RevdDate, "YYYYMMDD-HHNNSS") _
                                                    & " - " & _
                                            Item.Subject & Ext

            ItemSubject = FileNameUnique(Path, ItemSubject, Ext)

            Item.SaveAs Path & ItemSubject, olTXT
            Item.Move SubFolder
        End If
    Next

    Set olNs = Nothing
    Set Inbox = Nothing
    Set SubFolder = Nothing
    Set Items = Nothing

End Sub


'// Check if the file exists
Private Function FileExists(FullName As String) As Boolean
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    If fso.FileExists(FullName) Then
        FileExists = True
    Else
        FileExists = False
    End If

    Exit Function
End Function

'// If the same file name exist then add (1)
Private Function FileNameUnique(Path As String, _
                               FileName As String, _
                               Ext As String) As String
Dim lngF As Long
Dim lngName As Long
    lngF = 1
    lngName = Len(FileName) - (Len(Ext) + 1)
    FileName = Left(FileName, lngName)

    Do While FileExists(Path & FileName & Chr(46) & Ext) = True
        FileName = Left(FileName, lngName) & " (" & lngF & ")"
        lngF = lngF + 1
    Loop

    FileNameUnique = FileName & Chr(46) & Ext

    Exit Function
End Function

在此方面的任何帮助，我将不胜感激.

I would appreciate any help with this.

推荐答案

此行接受由ItemAdd代码传递给它的Item.

This line accepts Item passed to it by the ItemAdd code.

Public Sub SaveMailAsFile(ByVal Item As Object)

您有混合的代码可以处理一项，而很多代码则可以处理许多项.

You have intermixed code to handle one item and code to handle many items.

您可以先处理一个项目，然后查找以前可能错过的邮件，现在在收件箱中未对其进行处理.

You could first process the one Item then look for mail that might have been missed previously and is now unprocessed in the Inbox.

Private Sub SaveMailAsFile(ByVal Item As Object)

    Dim olNs As Outlook.NameSpace
    Dim Inbox As Outlook.MAPIFolder
    Dim SubFolder As Outlook.MAPIFolder

    Dim Items As Outlook.Items
    Dim ItemSubject As String

    Dim RevdDate As Date
    Dim Path As String
    Dim Ext As String

    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)

    If Item.Subject = "VVAnalyze Results" Then

        Path = Environ("ltvstatus") & "C:\Users\ltvstatus\Desktop\Backup Reports\"
        ItemSubject = Item.Subject
        RevdDate = Item.ReceivedTime
        Ext = "txt"

        Debug.Print Item.Subject ' Immediate Window

        Set SubFolder = Inbox.Folders("Reports") ' <--- Update Fldr Name

        ItemSubject = Format(RevdDate, "YYYYMMDD-HHNNSS") _
                                                & " - " & _
                                        Item.Subject & Ext

        ItemSubject = FileNameUnique(Path, ItemSubject, Ext)

        Item.SaveAs Path & ItemSubject, olTXT
        Item.Move SubFolder

    End If

    SaveMailAsFile_Standalone ' Comment out to run separately if needed

ExitRoutine:
    Set olNs = Nothing
    Set SubFolder = Nothing
    Set Inbox = Nothing
    Set Items = Nothing

End Sub

Public Sub SaveMailAsFile_Standalone()

    Dim olNs As NameSpace
    Dim Inbox As Folder
    Dim SubFolder As Folder

    Dim resItems As Items
    Dim unprocessedItem As Object

    Dim ItemSubject As String
    Dim RevdDate As Date
    Dim Path As String
    Dim Ext As String

    Dim i As Long

    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)

    Set resItems = Inbox.Items.Restrict("[Subject] = 'VVAnalyze Results'")

    Path = Environ("ltvstatus") & "C:\Users\ltvstatus\Desktop\Backup Reports\"
    'ItemSubject = Item.Subject
    'RevdDate = Item.ReceivedTime
    Ext = "txt"

    For i = resItems.count To 1 Step -1

        Set unprocessedItem = resItems.Item(i)

        DoEvents

        If unprocessedItem.Class = olMail Then

            ItemSubject = unprocessedItem.Subject
            RevdDate = unprocessedItem.ReceivedTime

            Debug.Print unprocessedItem.Subject ' Immediate Window

            Set SubFolder = Inbox.Folders("Reports") ' <--- Update Fldr Name

            ItemSubject = Format(RevdDate, "YYYYMMDD-HHNNSS") _
                                                    & " - " & _
                                    unprocessedItem.Subject & Ext

            ItemSubject = FileNameUnique(Path, ItemSubject, Ext)

            unprocessedItem.SaveAs Path & ItemSubject, olTXT
            unprocessedItem.Move SubFolder

        End If
    Next

ExitRoutine:
    Set olNs = Nothing
    Set Inbox = Nothing
    Set SubFolder = Nothing
    Set resItems = Nothing
    Set unprocessedItem = Nothing

End Sub

这篇关于在Outlook中运行VBA脚本时出现运行时错误'-2147221241(80040107)的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！