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

我对编程非常陌生，并且一直在使用Excel中的VBA（宏记录器）。根据主题使用文件名保存批量附件

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

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

** **更新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

来源

2017-07-03 mrdj007

你有什么企图这么远吗？请张贴一些代码。 – mjsqu

我不完全清楚你想要做什么。您是否想将具有相同主题的邮件中的附件分组在一起？如果是这样，您可以编写代码来循环访问电子邮件收集并保存其附件，而不是全部放在同一个文件夹中，但放在以电子邮件主题命名的子文件夹中。您将不得不躲避一些陷阱，如主题中可能出现的文件夹名称中无效的字符，但它可能会满足您的需要。 – VBobCat

您好，您可能想要参考https://stackoverflow.com/questions/15531093/save-attachments-to-a-folder-and-rename-them并编辑它以使用'.subject'属性来确定文件名称等 – AiRiFiEd

这里是一些解析附件名称，并从该

它工作的四个例子计算一个文件名代码中给出

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

来源

2017-07-11 21:32:07 jsotola

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

回答

相关问题