バルク添付ファイル名で保存する

Question

私は非常にプログラミングの面倒で、ExcelでVBA（マクロレコーダー）を使用しています。

私は約500の大口支出、収入、毎月の予算レポートを送付します。これらのレポートにはそれぞれ固有の件名があります。サンプルの件名は "Report 001"となり、Excelの添付ファイルを "Project A 2016"として保存します。件名が「レポート002」の場合は、ファイルを「プロジェクトB 2015」などと保存してください。

もう1つの考えは、ファイル名を保存するための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