Office 365/Outlook 2016将包含字符串附件的文件移动到另一个文件夹

Question

我每天收到多个日志文件，并希望创建一个规则或vba脚本，将电子邮件移动到指定的文件夹。问题是，只有当它在xml附件中包含特定文本时，才应该移动它。我是VBA的新手，在网上找不到任何看起来特别有用的东西，而且我找不到用规则来做这件事的方法。

我能够找到正确的文件移动，如果我做一个手动搜索[ext:xml附件:TestScriptFailed]，但我不确定如何将其转化为规则或VBA脚本自动传输过程。

Answer 1

你已经成为会员26个月了，所以你应该知道这个网站是程序员互相帮助开发的。你在一个问题上问得太多了，而且没有明显的尝试去分解它。如果有人给你的宏几乎就是你想要的，你能理解它并完成它吗?我会试着让你开始。

我不知道有什么规则可以测试特定类型附件中的特定字符串，如果找到，保存该附件。我不是一个有经验的规则使用者，所以这可能是我的无知。SuperUser站点将是询问此类规则的更好的地方。我建议采用宏观策略。从每小时或每天或任何时候手动运行宏开始。还有更高级的技术，但在我们考虑最方便的运行方式之前，让我们先让宏工作起来。

首先，看看我的答案:如何使用VBA或宏将Outlook邮件复制到excel中

我们得到了很多问题沿着线:"我试图从电子邮件中提取xxxx并将其复制到Excel工作簿"。这是伴随着电子邮件的图像。提问者似乎无法理解的是，电子邮件的图像并没有告诉我们电子邮件的主体对于VBA宏是什么样子的。是文本还是Html，还是两者都有?如果是Html，格式是原生的还是CSS的?它是否使用带有class或id属性的SPAN或DIV元素来标识不同的部分?

引用的宏试图帮助提问者理解这个问题。它创建一个新的Excel工作簿，并输出收件箱中每个电子邮件的主要属性。

你的问题中没有任何迹象表明你对输出到Excel感兴趣，但我认为这对你来说是一个很好的开始。它读取收件箱检查每一封电子邮件。它提取可能有趣的主题和发送者。它列出了您需要的每个附件的类型和名称。它输出文本和Html主体，这可能是有趣的。

下载该宏，按指示更改目标文件夹并运行该宏。在工作簿中搜索您的"日志文件"电子邮件之一。Xml文件中的文本是表示它是日志文件电子邮件的唯一指示吗?这个宏提供了您想要的结构(它向下读取收件箱)，但包含了许多您不感兴趣的内容。您可以从该宏中删除不感兴趣的部分，也可以通过提取感兴趣的部分来创建一个新的宏。你能做到吗?如果你不能，你将无法处理更高级的功能，这是一个完整的解决方案所必需的。

我将不得不更新参考答案。我最近升级到Outlook 2016，发现了一个问题。我的安装没有使用宏搜索的默认收件箱，因此宏将创建一个空工作簿。Outlook 2016为每个电子邮件地址创建了一个名为[e-mail]的"存储"。在文件夹窗格中，这些是每个层次结构中的顶级名称。每个存储都包含自己的Inbox，用于存储发送到相关地址的新电子邮件。如果你的安装和我的一样，你必须替换:

Set FolderTgt = CreateObject("Outlook.Application"). _GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)由

Set FolderTgt = CreateObject("Outlook.Application"). _
GetNamespace("MAPI").Folders("[e-mail]").Folders("Inbox")

有了宏的结构之后，下一个问题是用包含标识文本的Xml附件识别电子邮件。你不能直接看电子邮件的附件。你必须把它们保存到光盘上并在那里处理它们。使用VBA，您可以将Xml文件作为文本文件打开，并扫描识别文本。如果我理解正确的话，它是包含您需要的标识文本的Xml文件。如果是这样，如果Xml包含标识文本，则将其留在磁盘上，否则将删除。如果Xml文件被保留，您需要将电子邮件移动到另一个文件夹，这样它就不会被再次检查。

我有:(1)将附件保存到磁盘，(2)将电子邮件从一个文件夹移动到另一个文件夹，(3)用VBA处理文本文件，虽然从来没有从Outlook，但从来没有在一个宏中。我将把这当作自己的一次训练练习，并开发您需要放入我告诉您开发的宏中的代码。

可能的问题1:这些日志文件有多大?电子邮件的容量限制在15Mb左右。VBA可以很容易地处理15Mb的文件，但是如果标识文本在前1000字节中，则不希望将此大小的整个文件加载到内存中。

可能问题2:日志文件有唯一的名称吗?如果它们具有唯一的名称，则可以在这些名称下保存它们。如果它们没有唯一的名称，则必须为它们生成唯一的名称。唯一的名称可以像"LFnnnn.Xml"一样简单，其中"nnnn"比前一个日志文件的编号多1。或者，它可以像您想要的那样复杂。

重读你的问题，我想我可能误解了你的要求。我听说你想把日志文件的附件移到光盘文件夹。我相信尼顿也是这么想的。我现在相信您希望将邮件转移到新的Outlook文件夹中，并且不指定日志文件附件的处理方法。我认为这种误解并不重要，也不会对所需的宏观产生实质性影响。包含日志文件的电子邮件具有必须移动到新的Outlook中，否则它将被一次又一次地处理。日志文件包含要被提取到一个光盘文件夹，以便其内容可以检查。我的代码在磁盘上留下一个包含标识文本的Xml文件。另外一条语句将删除这样一个Xml文件，就像删除那些不包含标识文本的Xml文件一样。我认为日志文件必须在某个时候提取。也许您没有意识到必须提取它们以满足您的要求。我让你决定是否添加Kill语句。

我说过默认的收件箱可能不是这些电子邮件加载到的收件箱。我创建了一个小宏，输出包含默认Inbox的存储的用户名，您可能会觉得有用:

Sub DsplUsernameOfDefaultStore()
Dim NS As Outlook.NameSpace
Dim DefaultInboxFldr As MAPIFolder
Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")
Set DefaultInboxFldr = NS.GetDefaultFolder(olFolderInbox)
Debug.Print DefaultInboxFldr.Parent.Name
End Sub

下面的宏为您的需求做了所有繁重的工作:

Public Sub SaveInterestingAttachment(ByRef ItemCrnt As MailItem, _
ByVal IdentExtn As String, _
ByVal IdentText As String, _
ByVal DestDiscFldr As String, _
ByRef DestOlkFldr As MAPIFolder)
' * ItemCrnt may contain one or more attachments which have extension
'   IdentExtn and which contains text IdentText. If it contains such
'   attachment(s) then the macro:
'     * saves all such attachments to disc folder DestDiscFldr
'     * moves the mail item to output folder DestOlkFldr.
' * Comparisons of IdentExtn and IdentText against file extensions and
'   contents are case insensitive because the strings are converted to
'   lower case before comparisons.
' * The phrase "saves all such attachments" is perhaps slightly
'   misleading. An attachment can only be checked to contain the
'   identifying text by saving it to disc, opening it and scanning the
'   contents. So all attachments with extension IdentExtn are saved to
'   disc and those that do not contain IdentText are deleted.
' Warning: This code assumes DestDiscFldr has a trailing 
' Warning: This code does not test for an existing file with the same name
' Warning: To compile, this macro needs a Reference to "Microsoft Scripting
'          RunTime". Click Tools then References. Click box against
'          "Microsoft Scripting RunTime" if not already ticked. The Reference
'          will be at the top if ticked. Unticked references are in
'          alphabetic sequence.
Const ForReading As Long = 1
Const OpenAsAscii As Long = 0
Dim FileContents As String
Dim FileXml As TextStream
Dim Fso As FileSystemObject
Dim InxA As Long
Dim LcExtn As String:   LcExtn = LCase(IdentExtn)
Dim LenExtn As Long:    LenExtn = Len(IdentExtn)
Dim LcIdText As String: LcIdText = LCase(IdentText)
Dim MoveEmail As Boolean
Dim PathFileName As String
With ItemCrnt
If .Attachments.Count > 0 Then
Set Fso = CreateObject("Scripting.FileSystemObject")
MoveEmail = False
For InxA = 1 To .Attachments.Count
If Right$(LCase(.Attachments(InxA).FileName), 1 + LenExtn) = _
"." & LcExtn Then
' My test files do not have unique names. Adding received time and
' subject was an easy way of making the names unique and demonstrates
' some options.
PathFileName = DestDiscFldr & Format(.ReceivedTime, "yymmddhhmmss") & _
" " & .Subject & " " & _
.Attachments(InxA).FileName
.Attachments(InxA).SaveAsFile PathFileName
Set FileXml = Fso.OpenTextFile(PathFileName, ForReading, OpenAsAscii)
FileContents = FileXml.ReadAll
' If your log files are large snd the identifying text is near
' the beginning, Read(N) would read the first N characters
If InStr(1, LCase(FileContents), LcIdText) <> 0 Then
' Xml file contains identifiying text
' Leave Xml on disc. Move email to save folder
MoveEmail = True
FileXml.Close
Else
' Delete Xml file. Leave email in Inbox unless another attachment
' contained the identifying text
FileXml.Close
Kill PathFileName
End If
Set FileXml = Nothing
End If
Next
If MoveEmail Then
.Move DestOlkFldr
End If
Set Fso = Nothing
End If
End With
End Sub

这个宏有五个参数:

• 要测试的邮件项的引用。
• 要测试的扩展名的值。
• 标识文本的值。
• 要保存附件的光盘文件夹的值。
• 对Outlook文件夹的引用，适当的邮件项目将被移动到该文件夹中。

我非常有信心，最终这段代码将不得不从两个不同的父宏调用，因此使Mail Item成为一个参数是必要的。其他参数可以硬编码到宏中，但将它们作为参数并不需要额外的努力，而且参数通常比隐藏在宏主体中的值更容易解释。

您需要通过阅读注释和检查语句来处理这个宏。我的测试数据是基于我对您要求的理解。如果我有误解，我的测试数据是错误的，这个宏可能会因为你的数据而失败。您需要仔细检查代码，然后用您的数据仔细测试它。

我需要一个测试工具来测试这个宏，因为带有参数的宏不能被用户调用。如果您已经创建了一个宏来读取Inbox，那么它将与我的测试工具非常相似。我的测试工具读取收件箱，并为每个邮件项调用SaveInterestingAttachment。

甚至比SaveInterestingAttachment更重要的是，必须仔细检查和更新这个宏。这个宏引用磁盘上的文件夹和Outlook安装中的文件夹。这些引用必须更新。

Sub TestSaveInterestingAttachment()
' For every mail item in Inbox, call SaveInterestingAttachment.
Dim DestOlkFldr As MAPIFolder
Dim SrcOlkFldr As MAPIFolder
Dim InxItemCrnt As Long
Dim NS As Outlook.NameSpace
Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")
' You only need one of the next two Set statements. If your Inbox is not
' Outlook's default then amend the second to reference your default Inbox.
' This is the easiest way to reference the default Inbox.
' However, you must be careful if, like me, you have multiple email addresses
' each with their own Inbox. The default Inbox may not be where you think it is.
Set SrcOlkFldr = NS.GetDefaultFolder(olFolderInbox)
' This references the Inbox in a specific PST or OST file.
' "[e-mail]" is the user name that Outlook gave the PST file in
' which it stores emails sent to this account when I created the account. The user
' name is the name Output displays to the user. The file name on disk is different. 
Set SrcOlkFldr = NS.Folders("[e-mail]").Folders("Inbox")
' I do not know where you want to save processed emails.
' In this description, a "store" is a file on disc in which Outlook stores
' your mail items, calendar items, tasks and so on. When you look at the
' folder pane, names against the left edge are the user names of stores.
' Indented names are folders within a store. The name of the file on disc
' is probably the same as the user name but with an extension of PST or OST.
' The first Set statement below shows how to reference a folder at the same
' level as Inbox in the same store. It does this by using property Parent to
' go up one level and then property Folders to go down one level.
' The second Set statement below shows how to reference a sub-folder of
' Inbox.  It does this by using property Folders to go down one level.
' The third Set statement below shows how tp reference a folder "Processed2"
' within folder "Inbox" within store "outlook data file".
' None of these Set statements will meet your requirements. Use these
' examples to build a Set statement suitable for your requirements.
Set DestOlkFldr = SrcOlkFldr.Parent.Folders("!Tony")
Set DestOlkFldr = SrcOlkFldr.Folders("Processed3")
Set DestOlkFldr = NS.Folders("outlook data file").Folders("Inbox").Folders("Processed2")
' This examines the emails in reverse order.
' If I process email number 5 and then move it to another folder,
' the number of all subsequence emails is decreased by 1. If I looked at the
' emails in ascending sequence, email 6 would be ignored because it would have
' been renumbered when I looked for it. By looking at the emails in reverse
' sequence, I ensure email 6 has bee processed before the removal of email 5
' changes its number.
With SrcOlkFldr.Items
For InxItemCrnt = .Count To 1 Step -1
If .Item(InxItemCrnt).Class = olMail Then
' I am only interested in mail items.
' You will need to replace the identying text and the
' destination disc folder
Call SaveInterestingAttachment(.Item(InxItemCrnt), "Xml", _
"identifying text", _
"C:DataAreaSO", DestOlkFldr)
End If  ' .Class = olMail
Next InxItemCrnt
End With
End Sub

我已经尝试了第二个测试线束。我最近升级到Outlook 2016，这是我第一次尝试使用它的事件。与我以前的版本完美工作的代码不再工作。这段代码不能正常工作有很多可能的原因。在我确定原因之前，我不会提供关于第二个测试线束的进一步信息。

更新2

我现在已经修复了我的第二个测试线束的问题。我几个月前还在用Outlook 2003，但一条语句显然不适用于Outlook 2016。

您将需要基于我的第一个测试工具的例程，因为该例程搜索收件箱中已经到达的日志文件电子邮件。我也相信这是测试SaveInterestingAttachment的一个更容易的例程，直到你把它更新到你的确切要求。

第二个测试工具位于后台，监视新邮件并处理包含日志文件的邮件。

我有一个家庭安装和电子邮件注册为新的，当他们从我的ISP服务器下载到我的硬盘驱动器。电子邮件只有在我打开Outlook的情况下才能下载。一旦我运行了测试工具1来清除收件箱中先前收到的日志文件电子邮件，我就可以依靠测试工具2来处理任何未来的日志文件电子邮件。

如果你有一个办公室安装，那么你的电子邮件可能会注册为新的，当他们到达你的组织的服务器。如果是这种情况，您将始终需要一个基于测试工具1的例程来处理那些夜间到达的日志文件电子邮件，或者当您没有打开Outlook时。

在Outlook的Visual Basic编辑器中，查看项目资源管理器窗格。在我的安装中，最上面一行是"Project1 (VbaProject.OTM)"。在您的安装中，顶部一行可能略有不同。

如果"Project1 (VbaProject.OTM)"左边有一个"+"，点击该"+"显示"Project1 (VbaProject.OTM)"下的项目。在我的安装这些是:"微软Outlook对象"，"表单"one_answers"模块"。你将没有任何表单。

如果"Microsoft Outlook对象"左侧有"+"，点击该"+"显示"Microsoft Outlook对象"下的项目。唯一显示的项将是" ThisOutlookSession "。

点击"ThisOutlookSession"，代码区域将变为空白。这是一个特殊的代码区。在前面，您将创建适合存储通用例程的模块。下面的代码只有在" ThisOutlookSession "内才能工作。

和以前一样，必须修改此代码以匹配您的Outlook安装和磁盘布局。完整的代码在底部，但我一点一点地介绍它，以帮助您理解它是做什么的。

我的代码包含:

• 选项显式
• 两个可被任意子程序访问的变量。
• 子例程Application_Startup ()
• 子程序InboxItems_ItemAdd(ByVal Item As Object)

您应该在每个模块的顶部有Option Explicit。如果你不知道为什么，就去查一下。

Subroutine Application_Startup()将在每次打开Outlook时执行。有了这个例程，您将在Outlook打开之前收到关于"ThisOutlookSession"的警告。如果要执行Application_Startup()，则需要启用宏。

我建议你从下面开始:

Private Sub Application_Startup()
' This event routine is called when Outlook is started
Dim UserName As String
With Session
UserName = .CurrentUser
End With
MsgBox "Welcome " & UserName
End Sub

将此代码复制到"ThisOutlookSession"，关闭Outlook并保存您的VBA项目。重新打开Outlook，启用宏，你会看到一个消息框，上面写着"欢迎Stephanie"。这没有什么有用的目的，但可以确保我们在做任何重要的事情之前有正确的信封。

Copy:Private WithEvents InboxItems As Items。研究以Set InboxItems =开头的语句及其上面的注释。您需要为您的收件箱构造一个适合此语句的版本。这个Set语句使InBoxItems引用收件箱。要确认，请转到宏的末尾，在那里您将发现:

Debug.Print InboxItems.Count
If InboxItems.Count > 0 Then
With InboxItems.Item(1)
Debug.Print .ReceivedTime & " " & .Subject & " " & .SenderEmailAddress
End With
End If

这些语句输出收件箱中的项目数和第一封电子邮件的详细信息，这几乎可以肯定是最早的电子邮件。一旦你复制了这些语句，关闭Outlook，保存VBA项目，然后再次打开Outlook。如果一切正常，即时窗口将包含电子邮件的计数和详细信息。如果不是，我们需要确定原因并纠正后再继续。

Copy:Private DestOlkFldr As MAPIFolder。研究以Set DestOlkFldr =开头的语句及其上面的注释。您需要为您的目标Outlook文件夹构造一个适合此语句的版本。再次转到宏的末尾，您将发现:

Debug.Print DestOlkFldr.Name
Debug.Print DestOlkFldr.Parent.Name
Debug.Print DestOlkFldr.Parent.Parent.Name

在我的系统上显示:

Processed2
Inbox
Outlook Data File

复制或创建尽可能多的Debug.Print语句，以适应您的目标Outlook文件夹的嵌套程度。关闭Outlook，保存VBA项目，然后再次打开Outlook。显示正确的名称吗?如果是，则Sub Application_Startup()正确。删除不再需要的诊断语句。

我们现在准备创建Sub InboxItems_ItemAdd(ByVal Item As Object)。我将以:

开头

Private Sub InboxItems_ItemAdd(ByVal Item As Object)
If TypeOf Item Is MailItem Then
With Item
Debug.Print "Mail item received at " & .ReceivedTime & " from " & _
.SenderEmailAddress & "(" & .Sender & ")"
End With
End If
End Sub

关闭Outlook，保存VBA项目，再次打开Outlook，等待一些电子邮件到达。如果有必要，给自己发封电子邮件。这些邮件的详细信息应该在即时窗口中。

最后，更新并复制下面的语句:

Call SaveInterestingAttachment(Item, "Xml", _
"identifying text", _
"C:DataAreaSO", DestOlkFldr)

关闭Outlook，保存VBA项目，再次打开Outlook，等待一些日志文件电子邮件到达。它们被正确处理了吗?

最后，总结一下:

Application_Startup()为保留名。当Outlook打开时，将自动执行具有此名称的子例程。这是事件例程的一个示例。事件例程在适当的事件发生时执行。我已经在Application_Startup()中包含了准备新邮件到达事件所需的代码。

InboxItems_ItemAdd(ByVal Item As Object)是Add item to InboxItems(即新邮件到达)事件例程的保留名称和强制规范。InboxItems是我们在顶部声明并初始化Application_Startup()的WithEvents变量。

如果你不习惯思考计算机事件以及它们发生时你想要发生什么，那么它们可能有点难以理解，尽管一旦你这样做了，你将很难记住问题是什么。我已经一步一步地介绍了它们。这就是我尝试新功能的方式。如果有必要，再考虑一晚。相信我，一切都会恍然大悟的。

必要时带着问题回来，但是你自己理解的越多，你就会发展得越快。

Option Explicit
Private WithEvents InboxItems As Items
Private DestOlkFldr As MAPIFolder
Private Sub Application_Startup()
' This event routine is called when Outlook is started
Dim UserName As String
With Session
' In TestSaveInterestingAttachment() you have a statement like:
'       Set SrcOlkFldr = NS.GetDefaultFolder(olFolderInbox)
'    or Set SrcOlkFldr = NS.Folders("[e-mail]").Folders("Inbox")
' You need a similar statement here without the "NS" at the beginning
' and with ".Items" at the end.  For example:
'Set InboxItems = .GetDefaultFolder(olFolderInbox).Items
Set InboxItems = .Folders("[e-mail]").Folders("Inbox").Items
' In TestSaveInterestingAttachment() you have a statement like:
'       Set DestOlkFldr = SrcOlkFldr.Parent.Folders("!Tony")
'    or Set DestOlkFldr = SrcOlkFldr.Folders("Processed3")
'    or Set DestOlkFldr = NS.Folders("outlook data file").Folders("Inbox").Folders("Processed2")
' There is no equivalent of SrcOlkFldr here so you cannot use the first two formats
' as a basis for the statement here.  You must use the third format, without the
' leading NS, at the basis for the statement here. For example:
Set DestOlkFldr = .Folders("outlook data file").Folders("Inbox").Folders("Processed2")
UserName = .CurrentUser
End With
MsgBox "Welcome " & UserName
Debug.Print InboxItems.Count
If InboxItems.Count > 0 Then
With InboxItems.Item(1)
Debug.Print .ReceivedTime & " " & .Subject & " " & .SenderEmailAddress
End With
End If
Debug.Print DestOlkFldr.Name
Debug.Print DestOlkFldr.Parent.Name
Debug.Print DestOlkFldr.Parent.Parent.Name

End Sub
Private Sub InboxItems_ItemAdd(ByVal Item As Object)
' This event routine is called each time an item is added to Inbox because of:
'    "Private WithEvents InboxItems As Items" at the top of this ThisOutlookSession
' and
'    "Set InboxItems = Session.GetDefaultFolder(olFolderInbox).Items"
' or "Set InboxItems = Session.Folders("abcdefghi@Isp ").Folders("Inbox").Items"
' within "Private Sub Application_Startup()"
If TypeOf Item Is MailItem Then
With Item
Debug.Print "Mail item received at " & .ReceivedTime & " from " & _
.SenderEmailAddress & "(" & .Sender & ")"
End With
' You will need to replace the identying text and the
' destination disc folder
Call SaveInterestingAttachment(Item, "Xml", _
"identifying text", _
"C:DataAreaSO", DestOlkFldr)
End If
End Sub