0

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

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

4

1 回答 1

1

您已经成为会员 26 个月，所以您应该知道这个网站是为程序员互相帮助开发的。您在一个问题中问的太多了，并且没有做出明显的尝试来分解它。如果有人给你的宏几乎是你想要的，你会理解到足以完成它吗？我会尽力让你开始。

我不知道有什么规则可以测试特定类型附件中的特定字符串，如果找到，则保存该附件。我不是规则的经验丰富的用户，所以这可能是我的无知。SuperUser 站点是询问此类规则的更好地方。我会建议一个宏。首先每小时或每天一次或任何时候手动运行宏。还有更高级的技术，但在我们担心最方便的运行方式之前，让我们先让宏工作。

首先，看看我的这个答案：How to copy Outlook mail message into excel using VBA or Macros

我们收到很多问题：“我正在尝试从电子邮件中提取 xxxx 并将其复制到 Excel 工作簿中”。这附有电子邮件的图像。提问者似乎无法理解的是，电子邮件的图像并没有告诉我们电子邮件的正文在 VBA 宏中的样子。它是文本还是 Html 或两者兼而有之？如果是 Html，格式是原生的还是 CSS？它是否使用具有 class 或 id 属性的 SPAN 或 DIV 元素来标识不同的部分？

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

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

下载该宏，按照说明更改目标文件夹并运行宏。在工作簿中搜索您的一封“日志文件”电子邮件。Xml 文件中的文本是否是日志文件电子邮件的唯一指示？这个宏给出了你想要的结构（它读取收件箱），但包含很多你不感兴趣的东西。您可以从该宏中删除不感兴趣的位，也可以通过提取有趣的位来创建新的宏。你能做到吗？如果您不能，您将无法处理满足您要求的完整解决方案所需的更高级功能。

我将不得不更新引用的答案。我最近升级到 Outlook 2016 并发现了一个问题。我的安装不使用宏搜索的默认收件箱，因此宏会创建一个空工作簿。Outlook 2016 为每个电子邮件地址创建了一个“存储”，其名称格式为：abcdefghi@isp.com。在文件夹窗格中，这些是每个层次结构中的顶级名称。这些商店中的每一个都包含自己的收件箱，用于存储发送到相关地址的新电子邮件。如果你的安装和我的一样，你将不得不更换：

Set FolderTgt = CreateObject("Outlook.Application"). _
GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
经过
Set FolderTgt = CreateObject("Outlook.Application"). _
GetNamespace("MAPI").Folders("abcdefghi@isp.com").Folders("Inbox")

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

我有：（1）将附件保存到光盘，（2）将电子邮件从一个文件夹移动到另一个文件夹，（3）用 VBA 处理文本文件，虽然从来没有来自 Outlook，但从来没有在一个宏中。我会将其视为对自己的培训练习，并开发您需要放入我告诉您开发的宏中的代码。

可能的问题 1：这些日志文件有多大？电子邮件似乎有大约 15Mb 的限制。VBA 可以轻松处理 15Mb 的文件，但如果标识文本位于前 1,000 个字节中，您不希望将这种大小的整个文件加载到内存中。

可能的问题 2：日志文件是否具有唯一名称？如果它们具有唯一名称，则可以将它们保存在这些名称下。如果它们没有唯一名称，则必须为它们生成唯一名称。唯一名称可以像“LFnnnn.Xml”一样简单，其中“nnnn”比前一个日志文件的编号大一。或者，它可以像你想要的那样复杂。

更新

重读您的问题，我相信如果我可能误解了您的要求。我读到您希望将日志文件附件移动到光盘文件夹。我相信 niton 以同样的方式阅读它。我现在相信您希望将邮件项目移动到新的 Outlook 文件夹，并且不指定日志文件附件会发生什么。我认为这种误解并不重要，也不会对所需的宏观产生重大影响。必须将包含日志文件的电子邮件移至新的 Outlook，否则它将被一次又一次地处理。一个日志文件有解压到光盘文件夹，以便检查其内容。我的代码在光盘上留下了一个包含识别文本的 Xml 文件。一个附加语句将删除这样的 Xml 文件，就像删除那些不包含标识文本的 Xml 文件一样。我假设必须在某个时候提取日志文件。也许您没有意识到必须提取它们才能满足您的要求。我让您决定是否添加该Kill声明。

我说默认收件箱可能不是加载这些电子邮件的收件箱。我创建了一个小宏，它输出包含默认收件箱的商店的用户名，您可能会觉得这很有帮助：

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 设为参数。其他参数可以被硬编码到宏中，但是使它们成为参数并不需要额外的努力，而且参数通常更容易解释隐藏在宏主体中的值。

您需要通过阅读评论和查看语句来处理此宏。我的测试数据是基于我对您的要求的理解。如果我有误解并且我的测试数据有问题，那么这个宏可能会因您的数据而失败。您需要仔细检查代码，然后用您的数据仔细测试它。

我需要一个测试工具来测试这个宏，因为用户不能调用带有参数的宏。如果您创建了一个宏来读取收件箱，它将与我的测试工具非常相似。我的测试工具读取收件箱并调用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.
  ' "abcdefghi@MyIsp.com" 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("abcdefghi@MyIsp.com").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:\DataArea\SO\", 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 编辑器中，查看 Project Explorer 窗格。在我的安装中，第一行是“Project1 (VbaProject.OTM)”。在您的安装中，顶行可能会略有不同。

如果“Project1 (VbaProject.OTM)”左侧有一个“+”，单击该“+”以显示“Project1 (VbaProject.OTM)”下的项目。在我的安装中，这些是：“Microsoft Outlook 对象”、“表单”和“模块”。你不会有任何表格。

如果“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”。这没有任何用处，但可以确保我们在做任何重要的事情之前有正确的信封。

复制：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。如果一切正常，即时窗口将包含电子邮件的计数和详细信息。如果不是，我们需要在继续之前找出原因并纠正它。

复制：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

根据目标 Outlook 文件夹的嵌套深度，复制或创建尽可能多Debug.Print的语句。关闭 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:\DataArea\SO\", DestOlkFldr)

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

最后，回顾一下：

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

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

如果您不习惯思考计算机事件以及当它们发生时您希望发生什么，它们可能会有点难以理解，尽管一旦您这样做了，您将很难记住问题所在。我已经分小步介绍了它们。这就是我尝试新功能的方式。如有必要，睡在上面。相信我，突然之间一切都会变得有意义。

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

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("abcdefghi@Isp.com").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("abcdefghi@Isp.com").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:\DataArea\SO\", DestOlkFldr)
  End If

End Sub
于 2016-10-08T12:24:24.667 回答