Save attachments to a new Windows folder? - vba

Question

Every time I receive an email with the subject "Test", I want to:
Automatically extract all attachments and store them in its own new created folder.
Automatically copy the email inside this new folder
Automatically add a Word document inside this new folder.
The folder must be named by the date received.
The code I have copies all attachments in a pre-selected folder, but it doesn't create a personal folder for them.
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
'Only act if it's a MailItem
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
'Change variables to match need. Comment or delete any part unnecessary.
If (Msg.Subject = "Heures") And _
(Msg.Attachments.Count >= 1) Then
'Set folder to save in.
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim Att As Variant
Const attPath As String = "C:\Users\NASC02\Test\"
' save attachment
Set myAttachments = item.Attachments
For Each Att In myAttachments
Att.SaveAsFile attPath & Att.FileName
Next
' mark as read
Msg.UnRead = False
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub

Answer 1

The code
Set myAttachments = item.Attachments
Att = myAttachments.item(1).DisplayName
myAttachments.item(1).SaveAsFile attPath & Att
needs to be changed to
Set myAttachments = item.Attachments
for each Att in myAttachments
Att.SaveAsFile attPath & Att.FileName
next