时间戳

首页 > 解决方案 > 检测新邮件，然后提取、解压缩和重命名附件

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

问题描述

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

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

电子邮件 3 和 4 也可以被 VBA 识别，附件是 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

标签： vbaoutlook

解决方案

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

就我而言，我在 60 秒内接连收到两封电子邮件。两封邮件的主题中都有“FP”和 .pdf 附件。任务是使用已安装的 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)\PDF24\pdf24-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

推荐阅读