vba - 从收到日期提取电子邮件附件
问题描述
我有从特定电子邮件文件夹中提取所有电子邮件附件的代码。
我想更改为从我在对话框中输入的日期开始提取电子邮件附件。我想从过去 7 天收到的电子邮件中提取电子邮件附件。
Sub Extract_emails()
Dim OlApp As Object
Dim OlMail As Object
Dim OlItems As Object
Dim Olfolder As Object
Dim J As Integer
Dim strFolder As String
Set OlApp = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Set OlApp = CreateObject("Outlook.Application")
End If
strFolder = ThisWorkbook.Path & "\Extract"
Set Olfolder = OlApp.getnamespace("MAPI").Folders("MyEmailAddress").Folders("Inbox")
Set OlItems = Olfolder.Items
For Each OlMail In OlItems
If OlMail.Attachments.Count > 0 Then
For J = 1 To OlMail.Attachments.Count
OlMail.Attachments.Item(J).SaveAsFile strFolder & "\" & OlMail.Attachments.Item(J).Filename
Next J
End If
Set OlApp = Nothing
Set OlMail = Nothing
Set OlItems = Nothing
Set Olfolder = Nothing
Next
MsgBox ("Done")
End Sub
我只需要提取 xlsx 附件（供应商发送 Excel 和 pdf 文档）并将它们保存在文件夹中。在我需要打开保存的 Excel 文件并在基础中复制数据并关闭保存的 xlsx 之后。我不知道 xlsx 文件的名称（通常是我们的公司名称和一些数字），但每份报告都有“运送”的表格，我从中复制数据。没有人阅读这些电子邮件，这就是我尝试使用未读电子邮件的原因。
适用于 F8 但不适用于 F5 的代码。
Set OlApp = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Set OlApp = CreateObject("Outlook.Application")
End If
strFolder = ThisWorkbook.Path & "\Extract"
Set Olfolder = OlApp.getnamespace("MAPI").Folders("Freight.Invoice@omega.com").Folders("Inbox")
Set OlItems = Olfolder.Items
For Each OlMail In OlItems
If OlMail.UnRead = True Then
If OlMail.Attachments.Count > 0 Then
For J = 1 To OlMail.Attachments.Count
FilePath = strFolder & "\" & OlMail.Attachments.Item(J).FileName
OlMail.Attachments.Item(J).SaveAsFile FilePath
If Right(FilePath, 4) = "xlsx" Then
runit FilePath
For I = 1 To Worksheets.Count
If Worksheets(I).Name = "Shipped" Then
Worksheets("Shipped").Activate
Set wsCopy = Worksheets("Shipped")
Set wsDest = Workbooks("Extract
emails.xlsm").Worksheets("DATA")
lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count,
"B").End(xlUp).Row
lDestLastRow = wsDest.Cells(wsDest.Rows.Count,
"B").End(xlUp).Offset(1).Row
wsCopy.Range("B4:K" & lCopyLastRow).Copy _
wsDest.Range("B" & lDestLastRow)
Worksheets("Shipped").Activate
ActiveWorkbook.Close savechanges:=False
End If
Next
End If
Next J
End If
End If
Next
For Each OlMail In OlItems
If OlMail.UnRead = True Then
OlMail.UnRead = False
DoEvents
OlMail.Save
End If
Set OlApp = Nothing
Set OlMail = Nothing
Set OlItems = Nothing
Set Olfolder = Nothing
Next
MsgBox ("Done")
End Sub
Sub runit(FilePath As String)
Dim Shex As Object
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long
Set Shex = CreateObject("Shell.Application")
Shex.Open (FilePath)
End Sub
解决方案
这是一个教程，而不是您问题的直接答案。我涵盖了你需要知道的一切。我相信您会发现这种方法比“运行此代码并且它会起作用”的答案更有用。我希望我已经充分解释了一切。如有必要，请回来提出问题。
您需要将电子邮件的 ReceivedTime 与最早的所需日期进行比较。您说您打算输入最早的所需日期，并且您还说您想要最后 7 天。可能有替代方案。在即时窗口中键入以下命令（注释除外）。
? now() The current date and time
? datevalue(now()) The current date
? dateadd("d",-7,now()) Seven days before now
? dateadd("d",-7,datevalue(now())) Seven days ago
? dateadd("ww",-1,datevalue(now())) One week ago
这些表达中的任何一个都给了你想要的日期吗？在DateAdd中，“d”和“ww”是间隔，“d”表示天，“ww”表示周。还有其他值，例如“w”表示工作日。试试这些表达式中的一个是否几乎可以满足您的需求。
其他可能性包括在保存附件时设置类别或自定义属性。
如果您还没有这样做，请打开您的工作簿和 VBA 编辑器。单击 [工具]，然后单击 [参考...]。“Microsoft Outlook nn.n 对象库”是否靠近列表顶部并已勾选？注意：“nn.n”取决于您使用的 Office 版本。如果此库未列出并打勾，请向下滚动直到找到它，然后单击小框以打勾。这使您的工作簿可以访问 Outlook 数据项，因此您不必指定这么多对象。
现在创建一个新模块并将下面的代码复制到它。如果你运行宏Demo()，你会得到这样的输出：
Oldest additions to Inbox
[14/12/2019 18:21:21] [28/12/2019 05:05:00] [08/01/2020 18:37:09] [28/03/2019 16:16:12] [21/03/2019 14:00:08]
[14/06/2018 21:02:34] [03/02/2020 09:29:38] [06/03/2020 17:03:50] [11/03/2020 13:43:33] [12/03/2020 00:07:53]
[13/03/2020 08:46:58] [13/03/2020 17:31:23] [14/03/2020 03:42:53] [14/03/2020 08:07:35] [14/03/2020 08:58:11]
[15/03/2020 19:43:16] [16/03/2020 16:48:40] [16/03/2020 20:39:58] [17/03/2020 11:14:29] [18/03/2020 01:43:37]
Newest additions to Inbox
[18/03/2020 01:43:37] [17/03/2020 11:14:29] [16/03/2020 20:39:58] [16/03/2020 16:48:40] [15/03/2020 19:43:16]
[14/03/2020 08:58:11] [14/03/2020 08:07:35] [14/03/2020 03:42:53] [13/03/2020 17:31:23] [13/03/2020 08:46:58]
[12/03/2020 00:07:53] [11/03/2020 13:43:33] [06/03/2020 17:03:50] [03/02/2020 09:29:38] [14/06/2018 21:02:34]
[21/03/2019 14:00:08] [28/03/2019 16:16:12] [08/01/2020 18:37:09] [28/12/2019 05:05:00] [14/12/2019 18:21:21]
Newest emails in Inbox
[20/03/2020 12:16:47] [20/03/2020 00:00:14] [19/03/2020 17:51:21] [19/03/2020 17:06:38] [19/03/2020 10:19:36]
[18/03/2020 16:21:25] [18/03/2020 01:43:37] [17/03/2020 11:14:29] [16/03/2020 20:39:58] [16/03/2020 16:48:40]
[15/03/2020 19:43:16] [14/03/2020 08:58:11] [14/03/2020 08:07:35] [14/03/2020 03:42:53] [13/03/2020 17:31:23]
[13/03/2020 08:46:58] [12/03/2020 00:07:53] [11/03/2020 13:43:33] [06/03/2020 17:03:50] [03/02/2020 09:29:38]
Oldest emails in Inbox
[14/06/2018 21:02:34] [21/03/2019 14:00:08] [28/03/2019 16:16:12] [14/12/2019 18:21:21] [28/12/2019 05:05:00]
[08/01/2020 18:37:09] [03/02/2020 09:29:38] [06/03/2020 17:03:50] [11/03/2020 13:43:33] [12/03/2020 00:07:53]
[13/03/2020 08:46:58] [13/03/2020 17:31:23] [14/03/2020 03:42:53] [14/03/2020 08:07:35] [14/03/2020 08:58:11]
[15/03/2020 19:43:16] [16/03/2020 16:48:40] [16/03/2020 20:39:58] [17/03/2020 11:14:29] [18/03/2020 01:43:37]
注意事项：
我有Dim OutApp As New Outlook.Application。“新建”表示创建参考，而不仅仅是为参考创建数据项。这意味着我不需要GetObject或CreateObject。Outlook 一次只允许出现一次，因此我的“新建”或您CreateObject将引用现有的出现或根据需要创建新的出现。我也有OutApp.Quit在最后。这将关闭 Outlook，无论它是否已经打开。我在使用 Excel 工作簿访问 Outlook 时不使用 Outlook，因此我希望关闭 Outlook。如果您关心，请使用您的 Get 或 Create 代码，但记录哪个成功，这样您就知道是否需要 Quit。
我已将我的数据项命名OutApp为olApp. Outlook 使用前缀“ol”作为它的常量，所以我避免使用这个前缀，以防我的名字与 Outlook 中的一个匹配。
我用过Session而不是GetNamespace("MAPI"). 它们只是实现相同效果的不同方式。
ItemsInbox是一个“集合”；其他语言称为“列表”。集合就像一个数组，除了您可以在任何现有条目之前、中间或任何现有条目之后添加新条目。可以删除任何现有条目。
Outlook 在集合末尾添加新电子邮件。因此，如果您从头到尾阅读，则第一封电子邮件是收件箱中最先出现的电子邮件。如果您从尾到头阅读，则第一封电子邮件是最近添加到收件箱的电子邮件。这表明您可以从头到尾阅读并首先查看最近的电子邮件，当您收到超出范围的电子邮件时可以停止。但是，如果您将旧电子邮件从收件箱移至另一个文件夹，然后将其移回，则不会将其返回到旧位置；相反，它将被添加到末尾。
在下面的宏中，我首先列出了 20 封电子邮件的 ReceivedTime，从第一到最后，然后从最后到第一。您可能会看到有些是乱序的。
然后，在按 ReceivedTime 按降序然后升序排序后，我列出了 20 封电子邮件的 ReceivedTime。
研究四个日期块。特别要注意不同的顺序。我相信第三块日期后面的代码将最适合您。
我想我已经涵盖了所有内容，但正如我所说，如有必要，我会回来提出问题，我会修复任何缺陷。
Option Explicit
' Needs reference to "Microsoft Outlook n.nn Object Library"
' where n.nn depends on the version of Outlook you are using.
Sub Demo()
Dim FldrInbox As Outlook.Folder
Dim InxICrnt As Long
Dim InxIMax As Long
Dim ItemsInbox As Outlook.Items
Dim NumOnLine As Long
Dim OutApp As New Outlook.Application
Set FldrInbox = OutApp.Session.Folders("a.j.dallimore@xxxxxxx.com").Folders("Inbox")
Set ItemsInbox = FldrInbox.Items
If ItemsInbox.Count > 20 Then
InxIMax = 20
Else
InxIMax = ItemsInbox.Count
End If
Debug.Print "Oldest additions to Inbox"
NumOnLine = 0
For InxICrnt = 1 To InxIMax
Debug.Print " [" & ItemsInbox(InxICrnt).ReceivedTime & "]";
NumOnLine = NumOnLine + 1
If NumOnLine = 5 Then
Debug.Print
NumOnLine = 0
End If
Next
Debug.Print
Debug.Print "Newest additions to Inbox"
NumOnLine = 0
For InxICrnt = InxIMax To 1 Step -1
Debug.Print " [" & ItemsInbox(InxICrnt).ReceivedTime & "]";
NumOnLine = NumOnLine + 1
If NumOnLine = 5 Then
Debug.Print
NumOnLine = 0
End If
Next
Debug.Print
ItemsInbox.Sort "ReceivedTime", True
Debug.Print "Newest emails in Inbox"
NumOnLine = 0
For InxICrnt = 1 To InxIMax
Debug.Print " [" & ItemsInbox(InxICrnt).ReceivedTime & "]";
NumOnLine = NumOnLine + 1
If NumOnLine = 5 Then
Debug.Print
NumOnLine = 0
End If
Next
Debug.Print
ItemsInbox.Sort "ReceivedTime", False
Debug.Print "Oldest emails in Inbox"
NumOnLine = 0
For InxICrnt = 1 To InxIMax
Debug.Print " [" & ItemsInbox(InxICrnt).ReceivedTime & "]";
NumOnLine = NumOnLine + 1
If NumOnLine = 5 Then
Debug.Print
NumOnLine = 0
End If
Next
Debug.Print
Set ItemsInbox = Nothing
OutApp.Quit
Set OutApp = Nothing
End Sub
修订要求
每周左右，您都会收到一封来自供应商的电子邮件，其中包含 PDF 和 XLSX 格式的发票。Outlook 规则会识别该电子邮件并将其移至专用文件夹。您的团队对 PDF 版本不感兴趣。XLSX 工作簿没有一致的名称。但是，它始终包含一个“已发货”工作表，其中包含对您的团队有用的数据。目前，您不会尝试通过宏处理该数据，但您希望将其合并到您自己的工作簿中，以便团队可以方便地查看。目前，所需的格式是：
Columns B to K of row 4+ of worksheet “Shipped” for week starting 1Mar20
: : : : :
Columns B to K of row 4+ of worksheet “Shipped” for week starting 8Mar20
: : : : :
Columns B to K of row 4+ of worksheet “Shipped” for week starting 15Mar20
: : : : :
审查实现要求的想法
如果您在几个月前问过，我会建议使用“运行脚本”将宏链接到规则。Microsoft 已决定“运行脚本”是危险的，默认情况下不再可用。有在线帮助解释了如何使“运行脚本”可用，但我建议您等到您更有经验后再尝试此操作。
我建议修改合并数据的格式：
Data from email received 2Mar20 9:10
Entire contents of worksheet “Shipped”
Data from email received 9Mar20 9:30
Entire contents of worksheet “Shipped”
Data from email received 16Mar20 9:20
Entire contents of worksheet “Shipped”
标题行意味着不会混淆一周数据的结束位置和另一周的数据开始位置。包括工作表中的标题行和所有列意味着如果他们添加另一列，它仍将包含在您的合并中，如果他们更改顺序，您将收到警告。
宏不必与数据位于同一工作簿中。对于此类任务，我通常将宏和数据分开。数据定期更新，但宏只是偶尔更新。例如，我每个月都会下载我的银行对账单，并将它们合并成一个连续多年的对账单。我只在他们更改下载格式时更改宏。
您不需要通过例如测试 UnRead 属性来识别电子邮件的代码，因为感兴趣的电子邮件将是专用文件夹中的最新电子邮件。您可能会在新电子邮件到达之前调用宏，因此宏会查看上周的电子邮件。如果它检查合并工作表中的最新标题，它将知道它有一个旧工作簿并且可以退出而不进行更改。
以下是我的建议。如果您不知道如何实现我的某些想法，请不要担心，因为我确实知道如何实现。
您有两个名为“Consolidation Macros V02.xlsm”和“Consolidated Data V25.xlsx”的工作簿。每当收到新发票时，您就打开最新的合并宏工作簿并启动合并宏。打开工作簿时可以自动启动宏，但我建议我们暂时保留它。宏打开最新的数据工作簿并记录最近添加的日期。它访问 Outlook，查找最新的发票电子邮件，并根据最近添加的日期检查其日期。除非最新发票电子邮件的日期晚于最新添加的日期，否则宏将终止。如果日期令人满意，宏会找到 XLSX 附件并将其保存到光盘中。它打开那个工作簿，
您会注意到我对每个工作簿都有一个版本号。在我的工作生涯中，我看到了太多的灾难，因为人们在更新文件时没有保存新版本。如果您不想要它们，我可以删除版本号。
您认为以上内容符合您的要求吗？
推荐阅读
- python - 将 KivyMD ListItem 添加到 MDList 会在第一个成员之后产生空白成员
- google-colaboratory - 如何在 google colab 中导入 cplex？
- python - 当某些单元格有多行时如何读取excel文件
- android - 在 TextField 之间切换时如何消除键盘闪烁？
- reactjs - 在 Typescript 中创建一个可以是特定 React 组件列表之一的类型？
- python - TypeError: can only concatenate str (not "tuple") to str 我该如何解决这个问题？
- discord - Discord 机器人翻译器
- powershell - pscustomobject 每行多行
- python - OpenCV-Python：绘制抛物线
- python - 自定义权限验证 Django Rest 框架