检测新邮件，然后提取、解压缩和重命名附件

Question

我每周收到来自3个不同发件人的4封电子邮件。

电子邮件1和2来自同一发件人，可以通过VBA进行识别。这些电子邮件包含zip文件，其中每个zip文件都有一个.csv文件。

VBA也可以识别电子邮件3和4，附件为Excel表(.xlsx)。

我想提取和解压缩(在需要的地方)，并将这4个文件保存在一个文件夹中作为；email1.report、email2.report等。
然后在不同的文件夹中为每个文件复制这4个文件，并进行类似的重命名；"今天的日期".email1.report.csv等

我想将这些步骤组合在一个代码中，并替换email1.report、email2.report等文件，而不提示"你想替换文件吗？是，否？">

是否可以检测到新的每周电子邮件并自动执行此操作？

我用来解压缩和保存的代码：

Else
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "zip" Then
FileNameFolder = "C:Users..."
FileName = FileNameFolder & Left(Atmt.FileName, (InStr(1, Atmt.FileName, ".zip") - 1)) & ".txt"
Atmt.SaveAsFile FileName
FileNameT = FileNameFolder & Atmt.FileName
Name FileName As FileNameT
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace((FileNameFolder)).CopyHere oApp.NameSpace((FileNameT)).Items
Kill FileNameT
i = i + 1
End If
Next Atmt
'item.Close
End If

Answer 1

我不会为您的特定问题开发代码，但我最近写了类似的东西。也许你可以从这里开始，改变你的标准等。

就我而言，在60秒内，我收到了两封电子邮件。这两封邮件的主题都有"FP"和一个.pdf附件。任务是使用安装的PDF24连接这些附件，幸运的是，PDF24提供了一个shell命令。这是放置在Outlook VBA工程资源管理器的"ThisOutlookSession"中的代码。

Public btAttachmentMails As Byte
Public dtArrivalStamp As Date
Public strPathFirstMailAttachment As String
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace
Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
If TypeName(Item) = "MailItem" Then
Dim i As Integer
Dim strDocumentsFolder As String
strDocumentsFolder = CreateObject("WScript.Shell").SpecialFolders(16)
strPathFirstMailAttachment = strDocumentsFolder & "attachment_mail1.pdf"
If Item.Subject Like "FP*" Then
If btAttachmentMails = 0 Then
'first mail -> save attachment and set counter to 1
btAttachmentMails = 1
dtArrivalStamp = Time
For i = 1 To Item.Attachments.Count
If InStr(Item.Attachments.Item(i).DisplayName, ".PDF") > 0 Then
Item.Attachments.Item(i).SaveAsFile strPathFirstMailAttachment
End If
Next i
ElseIf btAttachmentMails = 1 Then
Dim dtNow As Date: dtNow = Time
If TimeDiff(dtArrivalStamp, dtNow) <= 60 Then
'second mail within 60 seconds with subject containing "FP" -> save attachment and concatenate both via pdf24, then delete both files
'save attachment of second mail
Dim strPathSecondMailAttachment As String
strPathSecondMailAttachment = strDocumentsFolder & "attachment_mail2.pdf"
For i = 1 To Item.Attachments.Count
If InStr(Item.Attachments.Item(i).DisplayName, ".PDF") > 0 Then
Item.Attachments.Item(i).SaveAsFile strPathSecondMailAttachment
End If
Next i
'concatenate pdf documents via pdf24 shell
Dim strOutputPath As String
strOutputPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "" & Year(Date) & Month(Date) & Day(Date) & "_Wartungsplan_" & Replace(CStr(Time), ":", "-") & ".PDF"
Shell ("""C:Program Files (x86)PDF24pdf24-DocTool.exe"" -join -profile ""default/good"" -outputFile " & strOutputPath & " " & strPathFirstMailAttachment & " " & strPathSecondMailAttachment)
'inform user
MsgBox ("Files have been successfully concatenated. You can find the combined file on your desktop.")
'reset status, delete temporary documents
btAttachmentMails = 0
If CreateObject("Scripting.FileSystemObject").fileexists(strPathFirstMailAttachment) Then Kill strPathFirstMailAttachment
If CreateObject("Scripting.FileSystemObject").fileexists(strPathSecondMailAttachment) Then Kill strPathSecondMailAttachment
Else
'second mail did not arrive within 60 seconds -> treat as first mail
'save new arrival time and overwrite old firstMailAttachment with this one
dtArrivalStamp = Time
For i = 1 To Item.Attachments.Count
If InStr(Item.Attachments.Item(i).DisplayName, ".PDF") > 0 Then
Item.Attachments.Item(i).SaveAsFile strPathFirstMailAttachment 'overwrites existing file
End If
Next i
End If
End If
End If
End If
ExitNewItem:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description & " - please contact XY"
Resume ExitNewItem
End Sub
Function TimeDiff(StartTime As Date, StopTime As Date)
TimeDiff = Abs(StopTime - StartTime) * 86400
End Function

Answer 2

cr44sh在我创建我的答案时发布了一个答案。他建议使用新项目事件，而我建议使用规则。我更喜欢规则，但你可以选择你喜欢的方法。

不可能完全回答您的问题，但我相信我可以为您提供足够的帮助，让您自己构建所需的宏。

你说这些电子邮件可以用VBA识别。这表明最好的方法是Outlook规则，该规则使用"运行脚本"选项，其中"运行脚本"意味着"运行宏"。稍后我将讨论该规则，但首先您需要运行的宏。

您需要两个类似的宏：

Public Sub Type1Email(ByRef ItemCrnt As MailItem)
' Relevant code
End Sub
Public Sub Type2Email(ByRef ItemCrnt As MailItem)
' Relevant code
End Sub

我相信你可以为这些宏创建更好的名称。我读到要由规则运行的宏必须在ThisOutlookSession中。根据我的经验，只要它们被声明为Public，它们就可以在普通模块中。对于必须在该代码区域中的代码，我只使用ThisOutlookSession。如果代码可以在一个模块中，那就是我放置它的地方。我建议创建一个新的模块，命名为Module1或Module2。使用功能键F4访问其属性，并将其重命名为"ModRuleMacros"或类似名称。为模块提供有意义的名称可以让您更容易地找到今天要查看的代码。

尽管目标是创建一个由规则运行的宏，但您需要一种测试宏的方法。如果您将其中一些电子邮件保存在某个位置，您可以通过将其中一封电子邮件移动到收件箱来激活该规则。然而，我通常发现使用这样的宏更容易：

Sub TestType1Email()
Dim Exp As Explorer
Dim ItemCrnt As MailItem
Set Exp = Outlook.Application.ActiveExplorer
If Exp.Selection.Count = 0 Then
Call MsgBox("Pleaase select one or more emails then try again", vbOKOnly)
Exit Sub
Else
For Each ItemCrnt In Exp.Selection
Call Type1Email(ItemCrnt)
Next
End If
End Sub

若要使用此宏，请选择一个或多个Type1电子邮件，然后运行宏TestType1Email。此宏将一次一封地将选定的电子邮件传递给宏Type1Email。这将允许您单步执行宏Type1Email，并确保它能让您完全满意。我发现这是测试新Outlook宏的更简单的方法。

检查一条规则能为你做些什么可能会有所帮助。选择其中一封电子邮件，然后单击位于"开始"选项卡中间的">规则"，然后单击">创建规则…"。选择其中一封电子邮件意味着第一个窗口将充满一些选项。单击高级选项…。新窗口列出了用于选择电子邮件的所有选项。是否列出了选择类型1或类型2电子邮件所需的所有选项？这份清单很全面，但并不完整。例如，您不能根据附件的存在进行选择。确定您可以使用的选项，并确定您需要的缺少的选项。单击取消两次，即可从规则创建中存在。

您需要在宏中包含任何丢失选项的代码。

你的问题意味着你拥有处理电子邮件所需的所有代码，除了抑制替换问题。在创建新文件之前，您需要检查是否存在现有文件。这是我用来检查文件是否存在的例程：

Public Function FileExists(ByVal PathName As String, ByVal FileName As String) As Boolean
' Returns True if file exists.  Assumes path already tested.
' Coded by Tony Dallimore
' Based on code written by iDevlop: http://stackoverflow.com/a/28237845/973283
' Ensure only one "" between path and filename
If Right$(PathName, 1) <> "" Then
PathName = PathName & ""
End If
If Left$(FileName, 1) = "" Then
FileName = Mid$(FileName, 2)
End If
FileExists = False
On Error Resume Next
FileExists = ((GetAttr(PathName & FileName) And vbDirectory) <> vbDirectory)
On Error GoTo 0
End Function

如果文件存在，您可以：

• 使用VBA语句Kill(https://learn.microsoft.com/en-gb/office/vba/Language/Reference/user-interface-help/kill-statement)删除旧文件
• 使用VBA语句名称(https://learn.microsoft.com/en-gb/office/vba/language/reference/user-interface-help/name-statement)将旧文件移到另一个文件夹，或者通过在名称开头添加日期来重命名它

我喜欢第二个选项，因为我不喜欢删除文件，直到我真的，真的确定我不再需要它。在我的职业生涯中，我看到过太多的情况，因为不再需要而删除的文件在几个月后被发现处理不正确或不完整。

一旦完全测试了宏，就可以创建执行它们的规则。对于每种类型的电子邮件：

• 选择所需类型的电子邮件
• 单击规则，然后Create rule…
• 勾选第一个窗口上的任何相关框
• 单击高级选项…
• 勾选第二个窗口上的所有相关框
• 单击下一步
• 勾选"运行脚本"复选框
• 单击脚本
• 您将看到一个可以从规则中运行的所有宏的列表。选择所需的宏
• 单击下一步
• 勾选任何适当的例外情况，并输入所需的任何其他信息
• 单击下一步
• 命名规则。如果需要，请勾选"针对收件箱中已存在的任何邮件运行此规则"。查看规则并在必要时进行编辑
• 单击"完成">

我希望以上内容足以填补你知识上的漏洞。