使用Excel VBA将Outlook附件保存到PC上的文件夹

我正在尝试使用Excel VBA将Outlook子文件夹中的附件保存到C驱动器上的文件夹中

例如，在我的收件箱文件夹中，我有一个名为“data”的子文件夹，在该文件夹中，有不同数据的不同excel附件，但格式相同，附件名称相同，但日期更新（例如：“附件名称+3月28日”）

这些电子邮件每天都会发送。我希望所有尚未保存的附件都保存到C驱动器上的文件夹中，然后打开每个附件，将相关数据提取到Excel

一旦文件在我的C驱动器中，我就能够提取相关数据，但在没有Outlook VBA的情况下，我无法设置从Excel到Outlook的路径（我不想这样做）

这就是我到目前为止所做的：（这些评论是为了我的利益，因为我对这方面还不熟悉）

---

您需要一个启用宏的Excel工作簿，其中引用“Microsoft输出nn.n对象库”，其中“nn.n”取决于您正在运行的Office版本。请不要混用版本；我从未尝试过，但我知道这会带来问题

我假设您熟悉Excel VBA，并且知道如何创建启用宏的工作簿。根据你的评论，我想你不知道推荐人

VBA的大部分功能不是本机的，而是来自于库，如果您需要它们的功能，可以参考它们。打开VBA编辑器，单击“工具”，然后单击“参照”。你会得到一长串的可用参考资料。那些在顶部的将被勾选。例如，“Microsoft Excel nn.n对象库”将被勾选。如果没有此引用，编译器将不知道范围或工作表是什么。注意：“nn.n”取决于您使用的Office版本。对我来说，该值为“16.0”，因为我使用的是Office 365

未勾选的参考资料按字母顺序排列。向下滚动列表，直到找到“Microsoft Outlook nn.n对象库”。单击左侧的框以勾选此参照。单击“确定”。如果再次单击“工具”，然后单击“引用”，您将在顶部附近看到勾选的“Microsoft Outlook nn.n对象库”。编译器现在可以访问MailItem、Folder和Outlook对象模型的其余部分的定义

将以下代码复制到新模块：

Option Explicit
Sub ListStores()

  ' Needs reference to "Microsoft Output nn.n Object Library"
  ' where "nn.n" depends on the version of Outlook you are using.

  Dim AppOut As New Outlook.Application
  Dim InxStoreCrnt As Long
  Dim FldrInbox As Outlook.Folder

  With AppOut
    With .Session
      Debug.Print "List of stores:"
      For InxStoreCrnt = 1 To .Folders.Count
        Debug.Print "  " & .Folders(InxStoreCrnt).Name
      Next

      Set FldrInbox = .GetDefaultFolder(olFolderInbox)
      Debug.Print "Store for default Inbox: " & FldrInbox.Parent.Name

    End With
  End With

  AppOut.Quit
  Set AppOut = Nothing

End Sub

VBA通常有多种方法来达到预期效果。您在代码中使用了“名称空间”，而我使用了“会话”。文件说这两种方法是等效的。如果您自己编写代码，您可以选择您喜欢的任何方法。但是，如果您要寻找有用的代码片段，您必须为其他具有不同偏好的人做好准备

---

Dim AppOut As New Outlook。应用程序

创建一个Outlook实例，该实例将代表宏访问Outlook的文件

With AppOut
  With .Session
     :   :   :   :
  End With
End With

我可以用任何Outlook VBA替换

：

。如果Excel宏试图访问电子邮件，则会警告用户并要求其授予宏运行权限

Outlook将电子邮件、约会、任务等保存在它称为存储的文件中。您可能会看到这些称为PST文件的文件，因为大多数文件都有PST的扩展名，但OST文件也是一个存储。您可能会看到它们被称为帐户，因为默认情况下，Outlook会为每个电子邮件帐户创建一个存储。但是，您可以创建任意数量的额外存储，其中没有一个是帐户

此代码将创建您可以访问的门店列表：

  Debug.Print "List of stores:"
  For InxStoreCrnt = 1 To .Folders.Count
    Debug.Print "  " & .Folders(InxStoreCrnt).Name
  Next

输出可能类似于：

List of stores:
  Outlook Data File
  Smith John@ISPOne.com
  Archive Folders
  Backup
  John Smith@ISPTwo.com
  OutlookOutlook

以上是基于我的家庭安装。工作装置可能有些不同。差异将取决于安装过程中选择的选项。工作安装还可能包括系统中没有的共享文件夹

如果您查看文件夹窗格，您的名称下面会缩进其他名称。名称将是存储，并与宏列出的存储匹配，尽管顺序可能不同。文件夹窗格中的其他名称将是每个存储中的文件夹

我的宏的最后一点是：

  Set FldrInbox = .GetDefaultFolder(olFolderInbox)
  Debug.Print "Store for default Inbox: " & FldrInbox.Parent.Name

您有类似的代码来访问收件箱，但这可能不是您想要的收件箱。在我的系统上，此代码输出：

Store for default Inbox: Outlook Data File

“Outlook数据文件”是Outlook的默认存储。在我的系统中，日历和我的任务保存在此存储中，但我的电子邮件不保存。我有两个电子邮件帐户，每个帐户都有自己的商店

试试上面的宏。

GetDefaultFolder

是否找到需要访问的收件箱

现在添加此宏：

Sub ListStoresAndFirstEmails()

  ' Needs reference to "Microsoft Output nn.n Object Library"
  ' where "nn.n" depends on the version of Outlook you are using.

  Dim AppOut As New Outlook.Application
  Dim InxFldrCrnt As Long
  Dim InxStoreCrnt As Long
  Dim FldrInbox As Outlook.Folder

  With AppOut
    With .Session
      Debug.Print "List of stores and first emails:"
      For InxStoreCrnt = 1 To .Folders.Count
        Debug.Print "  " & .Folders(InxStoreCrnt).Name
        For InxFldrCrnt = 1 To .Folders(InxStoreCrnt).Folders.Count
          If .Folders(InxStoreCrnt).Folders(InxFldrCrnt).Name = "Inbox" Then
            Set FldrInbox = .Folders(InxStoreCrnt).Folders(InxFldrCrnt)
            If FldrInbox.Items.Count > 0 Then
              With FldrInbox.Items(1)
                Debug.Print "    Subject: " & .Subject
                Debug.Print "    Received: " & .ReceivedTime
                Debug.Print "    From: " & .SenderEmailAddress
              End With
            End If
            Exit For
          End If
        Next
      Next
    End With
  End With

  AppOut.Quit
  Set AppOut = Nothing
End Sub

此宏还用于调查您的商店。宏将扫描您的存储。对于每个商店，它会向下扫描一级文件夹列表，查找“收件箱”。如果它找到“收件箱”，则假定其中最早的项目是邮件项目，并输出其主题、接收时间和发件人。如果最旧的项目不是邮件项目，则会出现错误。我几乎希望你能得到一个错误来证明不做假设的重要性

最后加上：

Sub ListAttachments()

  Dim AppOut As New Outlook.Application
  Dim InxAttachCrnt As Long
  Dim InxItemCrnt As Long
  Dim InxStoreCrnt As Long
  Dim FldrData As Outlook.Folder

  With AppOut
    With .Session
      Set FldrData = .Folders("Outlook Data File").Folders("Inbox").Folders("Data")
    End With
  End With

  Debug.Print "List emails with attachments within: ";
  Debug.Print " " & FldrData.Name & " of " & FldrData.Parent.Name & _
              " of " & FldrData.Parent.Parent.Name
  With FldrData
    For InxItemCrnt = 1 To FldrData.Items.Count
      If .Items(InxItemCrnt).Class = olMail Then
        With .Items(InxItemCrnt)
          If .Attachments.Count > 0 Then
            Debug.Print "    Subject: " & .Subject
            Debug.Print "    Received: " & .ReceivedTime
            Debug.Print "    From: " & .SenderEmailAddress
            For InxAttachCrnt = 1 To .Attachments.Count
              Debug.Print "      " & InxAttachCrnt & " " & .Attachments(InxAttachCrnt).DisplayName
            Next
          End If
        End With
      End If
    Next
  End With

  AppOut.Quit
  Set AppOut = Nothing

End Sub

我总是在“Outlook数据文件”中保存一些垃圾邮件，以供测试之用

在

Set FldrData=.Folders（“Outlook数据文件”）.Folders（“收件箱”）.Folders（“数据”）

中，您需要将“Outlook数据文件”替换为包含感兴趣电子邮件的存储的名称。如果我理解正确，电子邮件位于文件夹“收件箱”下的文件夹“数据”中。如果我有误解，请注意我是如何使用“文件夹（xxxx）”链来访问所需文件夹的。在以前的电子邮件中，我使用索引访问商店和文件夹。这里我指定了一个特定的文件夹

在该文件夹中，我查找邮件项目（显示如何避免其他项目），如果它们有附件，请列出电子邮件的一些属性及其附件的名称

这是我所能做到的，因为我不完全理解您对附件命名方式的解释，也不完全理解您希望在哪里使用附件

Sub ListAttachments()

  Dim AppOut As New Outlook.Application
  Dim InxAttachCrnt As Long
  Dim InxItemCrnt As Long
  Dim InxStoreCrnt As Long
  Dim FldrData As Outlook.Folder

  With AppOut
    With .Session
      Set FldrData = .Folders("Outlook Data File").Folders("Inbox").Folders("Data")
    End With
  End With

  Debug.Print "List emails with attachments within: ";
  Debug.Print " " & FldrData.Name & " of " & FldrData.Parent.Name & _
              " of " & FldrData.Parent.Parent.Name
  With FldrData
    For InxItemCrnt = 1 To FldrData.Items.Count
      If .Items(InxItemCrnt).Class = olMail Then
        With .Items(InxItemCrnt)
          If .Attachments.Count > 0 Then
            Debug.Print "    Subject: " & .Subject
            Debug.Print "    Received: " & .ReceivedTime
            Debug.Print "    From: " & .SenderEmailAddress
            For InxAttachCrnt = 1 To .Attachments.Count
              Debug.Print "      " & InxAttachCrnt & " " & .Attachments(InxAttachCrnt).DisplayName
            Next
          End If
        End With
      End If
    Next
  End With

  AppOut.Quit
  Set AppOut = Nothing

End Sub