根据主题使用文件名批量保存附件

Question

我是编程新手，一直在 Excel 中使用 VBA（宏记录器）。

我将每月收到大约 500 份大宗支出、收入、预算报告，这些报告都有自己独特的主题行。一个示例主题行是“Report 001”，我想将 Excel 附件另存为“Project A 2016”。如果主题是“Report 002”，则将文件另存为“Project B 2015”等。

另一个想法是使用 vLookup 引用 Excel 表来保存文件名是合适的。这又是全新的，我缺乏方向。

** 更新 ** 2017 年 7 月 7 日

符合我需要的代码发布在下面。代码基于http://www.fontstuff.com/outlook/oltut01pfv.htm。

代码接收具有特定主题的电子邮件，并将具有特定命名约定的文件保存在我的桌面上。

我可以让我的代码更有效率吗？由于这是一个包含 4 个电子邮件主题的块，并且我可以批量接收超过 500 个，是否可以创建一个引用 csv 文件或其他内容的循环？

Sub GetAttachments6()

' This Outlook macro checks a named subfolder in the Outlook Inbox
' (here the "Sales Reports" folder) for messages with attached
' files of a specific type (here file with an "xls" extension)
' and saves them to disk. Saved files are timestamped. The user
' can choose to view the saved files in Windows Explorer.
' NOTE: make sure the specified subfolder and save folder exist
' before running the macro.
    On Error GoTo SaveAttachmentsToFolder_err
' Declare variables
    Dim ns As NameSpace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim i As Integer
    Dim varResponse As VbMsgBoxResult
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders("AutoRunReport") ' Enter correct subfolder name.
    i = 0
' Check subfolder for messages and exit of none found
    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in the AutoRunReport folder.", vbInformation, _
               "Nothing Found"
        Exit Sub
    End If
' Check each message for attachments
    For Each Item In SubFolder.Items
        For Each Atmt In Item.Attachments
            If Left(Item.Subject, 36) = "Monthly Auto Gen Report CY LD01_0210" Then
                FileName = "C:\Users\drowan\Desktop\TestTestTest\" & "LAB 2016 11 ENY 2016 0290000210 ADMIN" & ".pdf"
                Atmt.SaveAsFile FileName
                i = i + 1
            End If

            If Left(Item.Subject, 36) = "Monthly Auto Gen Report PY LD01_0210" Then
                FileName = "C:\Users\drowan\Desktop\TestTestTest\" & "LAB 2016 11 ENY 2015 0290000210 ADMIN" & ".pdf"
                Atmt.SaveAsFile FileName
                i = i + 1
            End If

            If Left(Item.Subject, 37) = "Monthly Auto Gen Report PPY LD01_0210" Then
                FileName = "C:\Users\drowan\Desktop\TestTestTest\" & "LAB 2016 11 ENY 2014 0290000210 ADMIN" & ".pdf"
                Atmt.SaveAsFile FileName
                i = i + 1
            End If

            If Left(Item.Subject, 36) = "Monthly Auto Gen Report CY LD01_0215" Then
                FileName = "C:\Users\drowan\Desktop\TestTestTest\" & "LAB 2016 11 ENY 2016 0290000215 HR" & ".pdf"
                Atmt.SaveAsFile FileName
                i = i + 1
            End If
        Next Atmt
    Next Item


' Show summary message
    If i > 0 Then
        varResponse = MsgBox("I found " & i & " attached files." _
        & vbCrLf & "I have saved them into the C:\Desktop\TestTestTest folder." _
        & vbCrLf & vbCrLf & "Would you like to view the files now?" _
        , vbQuestion + vbYesNo, "Finished!")
' Open Windows Explorer to display saved files if user chooses
        If varResponse = vbYes Then
            Shell "Explorer.exe /e,C:\Users\drowan\Desktop\TestTestTest\", vbNormalFocus
        End If
    Else
        MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
    End If
' Clear memory
SaveAttachmentsToFolder_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Exit Sub
' Handle Errors
SaveAttachmentsToFolder_err:
    MsgBox "An unexpected error has occurred." _
        & vbCrLf & "Please note and report the following information." _
        & vbCrLf & "Macro Name: GetAttachments" _
        & vbCrLf & "Error Number: " & Err.Number _
        & vbCrLf & "Error Description: " & Err.Description _
        , vbCritical, "Error!"
    Resume SaveAttachmentsToFolder_exit
End Sub

Answer 1

这是一些解析附件名称并从中计算文件名的代码

它适用于给定的四个示例

Sub GetAttachments6()

        ' This Outlook macro checks a named subfolder in the Outlook Inbox
        ' (here the "Sales Reports" folder) for messages with attached
        ' files of a specific type (here file with an "xls" extension)
        ' and saves them to disk. Saved files are timestamped. The user
        ' can choose to view the saved files in Windows Explorer.
        ' NOTE: make sure the specified subfolder and save folder exist
        ' before running the macro.

    On Error GoTo SaveAttachmentsToFolder_err

    Dim folderItems As Items
    Set folderItems = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("AutoRunReport").Items

    If folderItems.Count = 0 Then                                     ' Check subfolder for messages and exit of none found
        MsgBox "There are no messages in the AutoRunReport folder.", _
        vbInformation, "Nothing Found"
        GoTo ok_exit
    End If

    Dim Item As Object
    Dim Atmt As Attachment
    Dim subjElm() As String                                             ' array of subject line elements
    Dim fileName As String
    Dim year As String
    Dim deptNum As String
    Dim deptName As String
    Dim saveLocation As String

    saveLocation = "C:\Users\drowan\Desktop\TestTestTest\"

    Const sep As String = " "                                          ' separator between elements of resulting filename

    Dim filePrefix As String
    filePrefix = "LAB" & sep & "2016" & sep & "11" & sep & "ENY"       ' begining of each filename

            ' guesses and assumptions made:
            '     LD01_0215 and 0290000xxx signify department numbers
            '     last digit of department number (eg. LD01_0215) is department type
            '     cy, py, ppy .. are year codes

            ' "Monthly Auto Gen Report CY LD01_0210"  ==> "LAB 2016 11 ENY 2016 0290000210 ADMIN"
            ' "Monthly Auto Gen Report PY LD01_0210"  ==> "LAB 2016 11 ENY 2015 0290000210 ADMIN"
            ' "Monthly Auto Gen Report PPY LD01_0210" ==> "LAB 2016 11 ENY 2014 0290000210 ADMIN"
            ' "Monthly Auto Gen Report CY LD01_0215"  ==> "LAB 2016 11 ENY 2016 0290000215 HR"


    Dim i As Integer
    i = 0

    For Each Item In folderItems                                       ' Check each message for attachments
        For Each Atmt In Item.Attachments
            subjElm = Split(LCase(Item.Subject), " ", , vbTextCompare) ' split subject line into an array of words (zero based array)
                                                                       ' lcase function converts subject line to lower case

            '     0      1     2      3     4      5                   ' resulting index values of each element
            ' [Monthly][Auto][Gen][Report][PY][LD01_0210]              ' example subject line split into elements

            Select Case Trim(subjElm(4))
                Case "cy"
                    year = "2016"
                Case "py"
                    year = "2015"
                Case "ppy"
                    year = "2014"
                Case Else                  ' unspecified year
                    year = "noYear"
            End Select

            deptNum = "029000" & Split(subjElm(5), "_")(1)             ' [LD01_0210] ==> [LD01][0210]

            Select Case Right(Trim(subjElm(5)), 1)                     ' last character of LD01_0210
                Case "0"
                    deptName = "ADMIN"
                Case "5"
                    deptName = "HR"
                Case Else                  ' unspecified department
                    deptName = "noDeptName"
            End Select

            fileName = saveLocation & filePrefix & sep & year & sep & deptNum & sep & deptName & ".xls"
            Debug.Print "file path: " & fileName
            Atmt.SaveAsFile fileName

            i = i + 1

        Next Atmt
    Next Item


    If i > 0 Then                                    ' Show summary message

        Dim varResponse As VbMsgBoxResult

        varResponse = MsgBox("I found " & i & " attached file(s)." & vbCrLf _
                           & "I have saved them into the following folder:" & vbCrLf & vbCrLf _
                           & saveLocation & vbCrLf & vbCrLf _
                           & "Would you like to view the files now?" _
                           , vbQuestion + vbYesNo, "Finished!")

        If varResponse = vbYes Then
            Shell "Explorer.exe /e," & saveLocation, vbNormalFocus        ' Open Windows Explorer to display saved files
        Else
            MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
        End If

    End If
    GoTo ok_exit

' Handle Errors
SaveAttachmentsToFolder_err:
    MsgBox "An unexpected error has occurred." & vbCrLf _
         & "Please note and report the following information." & vbCrLf & vbCrLf _
         & "Macro Name:" & vbTab & "GetAttachments" & vbCrLf & vbCrLf _
         & "Error Number:" & vbTab & Err.Number & vbCrLf & vbCrLf _
         & "Error Description:" & vbTab & Err.Description _
         , vbCritical, "Error!"

ok_exit:
    Set Atmt = Nothing      ' Clear memory
    Set Item = Nothing
    Set folderItems = Nothing
End Sub