问题
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.
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
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.
Below is the entirety of the code:
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.
回答1:
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
回答2:
The error is MAPI_E_INVALID_ENTRYID, which usually means an entry id passed to Namespace.GetItemfromID cannot be recognized.
Are you sure you have the error location right? How is it possible for your script to successfully retrieve the Subject property and then fail on ReceivedTime?
来源：https://stackoverflow.com/questions/41830621/run-time-error-2147221241-80040107-while-running-vba-script-in-outlook