运行时错误'-在Outlook中运行VBA脚本时使用2147221241(80040107)
我有一个在Outlook中运行的VBA脚本,它应该将带有特定主题的传入电子邮件移动到Outlook中的子文件夹中,然后将这些电子邮件导出到TXT文件 这在很大程度上是可行的,但在导出几封电子邮件后,会弹出消息:“运行时错误”-2147221241(80040107)':操作失败。”弹出。我调试了它,它突出显示了代码行:运行时错误'-在Outlook中运行VBA脚本时使用2147221241(80040107),vba,outlook,Vba,Outlook,我有一个在Outlook中运行的VBA脚本,它应该将带有特定主题的传入电子邮件移动到Outlook中的子文件夹中,然后将这些电子邮件导出到TXT文件 这在很大程度上是可行的,但在导出几封电子邮件后,会弹出消息:“运行时错误”-2147221241(80040107)':操作失败。”弹出。我调试了它,它突出显示了代码行: RevdDate = Item.ReceivedTime 一旦出现此错误,我可以重新启动Outlook,它通常会导出没有问题的其余电子邮件。然而,我们需要这是完全自动化的,所
RevdDate = Item.ReceivedTime
一旦出现此错误,我可以重新启动Outlook,它通常会导出没有问题的其余电子邮件。然而,我们需要这是完全自动化的,所以我需要消除这个错误
以下是代码的全部内容:
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
选项显式
Private WithEvents项目作为Outlook.Items
私有子应用程序_启动()
将olNs设置为Outlook.NameSpace
将收件箱暗显为Outlook.Mapi文件夹
Set olNs=Application.GetNamespace(“MAPI”)
设置收件箱=olNs.GetDefaultFolder(olFolderInbox)
设置项目=收件箱。项目
端接头
私有子项\u ItemAdd(ByVal项作为对象)
如果项目类型为Outlook.MailItem,则
SaveMailAsFile项的调用子项
如果结束
端接头
公共子SaveMailAsFile(ByVal项作为对象)
将olNs设置为Outlook.NameSpace
将收件箱暗显为Outlook.Mapi文件夹
将子文件夹设置为Outlook.MAPIFolder
将项目设置为Outlook。项目
将项目主题设置为字符串
将NewName设置为字符串
将Dim重新设置为日期
将路径设置为字符串
Dim Ext作为字符串
我想我会坚持多久
Set olNs=Application.GetNamespace(“MAPI”)
设置收件箱=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”
对于i=项目。计数为1步骤-1
设置项目=项目。项目(i)
多芬特
如果Item.Class=olMail,则
调试.打印项目.主题'即时窗口
Set SubFolder=Inbox.Folders(“Reports”)错误为MAPI\u E\u INVALID\u ENTRYID
,这通常意味着无法识别传递到Namespace.GetItemfromID的条目id
您确定错误位置正确吗?脚本如何能够成功检索Subject属性,然后在ReceivedTime失败?此行接受ItemAdd代码传递给它的项
Public Sub SaveMailAsFile(ByVal Item As Object)
处理一个项目的代码和处理多个项目的代码混合在一起
您可以先处理一个项目,然后在收件箱中查找以前可能丢失但现在未处理的邮件
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
Private子SaveMailAsFile(ByVal项作为对象)
将olNs设置为Outlook.NameSpace
将收件箱暗显为Outlook.Mapi文件夹
将子文件夹设置为Outlook.MAPIFolder
将项目设置为Outlook。项目
将项目主题设置为字符串
将Dim重新设置为日期
将路径设置为字符串
Dim Ext作为字符串
Set olNs=Application.GetNamespace(“MAPI”)
设置收件箱=olNs.GetDefaultFolder(olFolderInbox)
如果Item.Subject=“VVAnalyze Results”,则
Path=Environ(“ltvstatus”)和“C:\Users\ltvstatus\Desktop\Backup Reports\”
ItemSubject=Item.Subject
RevdDate=Item.ReceivedTime
Ext=“txt”
调试.打印项目.主题'即时窗口
Set SubFolder=Inbox.Folders(“Reports”)'我对这一点相当陌生,但当我在收到错误消息后运行调试时,它只会突出显示RevdDate=Item.ReceivedTime。还有什么我需要检查以隔离问题的吗?您确定获得了MainItem对象吗?看起来您忽略了作为参数传递给SaveMailAsFile子文件的Item对象,而只是循环遍历特定文件夹中的所有匹配项。这就是你的意思吗?它应该将项目移动到子文件夹中,然后导出添加到子文件夹中的电子邮件。我与几个不同的人在这方面做过不同的工作,因为我绝不是一个程序员,所以旧版本中的某些内容可能会被遗漏。但是,每次将新项目添加到收件箱时,您的代码都会处理所有匹配的项目,而不仅仅是添加的项目。就在行前“RevdDate=Item.ReceivedTime”,能否添加以下MsgBox Item.Class