Enregistrement de pièce jointe en vrac avec le nom de fichier basé sur le sujet

Question

Je suis très nouveau en programmation et j'ai travaillé avec VBA (macro recorder) dans Excel.

Je recevrai environ 500 rapports sur les dépenses en vrac, les recettes et le budget sur une base mensuelle qui ont tous leur propre objet. Un exemple de ligne d'objet sera "Rapport 001" et je souhaite enregistrer la pièce jointe Excel en tant que "Projet A 2016". Si le sujet est "Rapport 002", alors enregistrez le fichier sous "Projet B 2015" etc.

Une autre idée est de faire référence à un tableau Excel en utilisant un vLookup pour enregistrer le nom du fichier. Encore une fois tout cela est nouveau et je manque de direction.

** Mise à jour ** 7/7/2017

Le code, le travail à mes besoins, est affiché ci-dessous. Le code est basé sur http://www.fontstuff.com/outlook/oltut01pfv.htm.

Le code prend des e-mails avec un sujet spécifique et enregistre les fichiers avec une convention de dénomination spécifique sur mon bureau. Puis-je rendre mon code plus efficace?

Puisqu'il s'agit d'un bloc de 4 sujets de courrier électronique et que je pourrais avoir plus de 500 dans un lot, une boucle pourrait-elle être créée en référence à un fichier 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

ici est un code qui analyse le nom de pièce jointe et calcule un nom de fichier de ce

cela fonctionne pour les quatre exemples donné

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