Prendre un courriel avec deux pièces jointes et enregistrer chaque pièce jointe dans un dossier différent

Question

Je reçois deux documents Excel dans un seul courriel, selon un horaire régulier. J'ai une règle mise en place qui peut enregistrer les documents joints à un seul dossier. Pour ce que je voudrais éventuellement automatiser, j'ai besoin de sauvegarder les documents dans différents dossiers. Jusqu'à présent, je peux éditer les noms des deux documents, mais quand j'essaie de comparer, un nom de fichier va dans le dossier x et l'autre dans le dossier y, soit je reçois les deux dans le dossier x, un seul apparaît jamais, ou ils ont tous deux poofed dans l'oubli.

Voici ce que j'ai jusqu'à présent:

Public Sub saveAttachtoDiskRule(itm As Outlook.MailItem) 

Dim objAtt As Outlook.Attachment 
Dim saveFolder As String 
Dim fso As Object 
Dim oldName 

Dim file As String 
Dim DateFormat As String 
Dim newName As String 

Dim enviro As String 
enviro = CStr(Environ("USERPROFILE")) 
saveFolder = enviro & "\Desktop\SWR\" 

Set fso = CreateObject("Scripting.FileSystemObject") 
On Error Resume Next 

For Each objAtt In itm.Attachments 


    '~> These two lines are where I run into trouble. 
    '~> Trying to change where I save the file. Only one at a time ever works. 
    If InStr(objAtt.DisplayName, "Team") <> 0 Then saveFolder = saveFolder & "Productivity\" 
    If InStr(objAtt.DisplayName, "Overdue") <> 0 Then saveFolder = saveFolder & "Overdue\" 


    file = saveFolder & objAtt.DisplayName 
    objAtt.SaveAsFile file 

    Set oldName = fso.GetFile(file) 

    '~> edits date to my specifications, works great 
    DateFormat = Format(DateAdd("d", -3, oldName.DateLastModified), "mm-dd-yyyy ") 
    '~> combines old name with date. Works great 
    newName = DateFormat & objAtt.DisplayName 

    oldName.Name = newName 

    Set objAtt = Nothing 
Next 

    Set fso = Nothing 
End Sub 

Answer 1

utiliser simplement si et commande Sinon, j'ai aussi ajouté de nouvelles Dim SavePath As String donc le code ne se confond pas à l'endroit où enregistrer le la pièce jointe.

voir le code complet.

Option Explicit 
Public Sub saveAttachtoDiskRule(itm As Outlook.MailItem) 
    Dim objAtt As Outlook.Attachment 
    Dim SaveFolder As String 
    Dim SavePath As String 
    Dim FSO As Object 
    Dim oldName 
    Dim file As String 
    Dim DateFormat As String 
    Dim newName As String 
    Dim enviro As String 

    enviro = CStr(Environ("USERPROFILE")) 
    SaveFolder = enviro & "\Desktop\SWR\" 

    Set FSO = CreateObject("Scripting.FileSystemObject") 
' On Error Resume Next 

    For Each objAtt In itm.Attachments 

     '~> These two lines are where I run into trouble. 
     '~> Trying to change where I save the file. Only one at a time ever works. 
'  If InStr(objAtt.DisplayName, "Team") <> 0 Then SaveFolder = SaveFolder & "Productivity\" 
'  If InStr(objAtt.DisplayName, "Overdue") <> 0 Then SaveFolder = SaveFolder & "Overdue\" 

     If InStr(objAtt.DisplayName, "Team.xlsx") Then 
      SavePath = SaveFolder & "Productivity\" 
     Else 
      If InStr(objAtt.DisplayName, "Overdue.xlsx") Then 
       SavePath = SaveFolder & "Overdue\" 
      End If 
     End If 

     file = SavePath & objAtt.DisplayName 

     objAtt.SaveAsFile file 

     Set oldName = FSO.GetFile(file) 

     '~> edits date to my specifications, works great 
     DateFormat = Format(DateAdd("d", -3, oldName.DateLastModified), "mm-dd-yyyy ") 
     '~> combines old name with date. Works great 
     newName = DateFormat & objAtt.DisplayName 

     oldName.Name = newName 

    Next 

    Set objAtt = Nothing 
    Set FSO = Nothing 
End Sub