Rule does not run when a new email comes in

Question

I worked out the code below to save an attachment to an email, to a mapped network drive, based on the subject line. However the rule in Outlook 2010 (xp OS) doesn't work when a new email comes in. It doesn't save it to the specified location. When I run the rule manually it works great.

I have enabled all macros. restarted Outlook no change. I have made macros prompt when running. It prompts when a new email comes in. I hit enable no save, no error that it didn't save.

Public Sub SaveAttachments2(mail As Outlook.MailItem)
On Error GoTo GetAttachments_err
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim f As String
Dim strSubject As String
Dim w As Integer

Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)

For Each Item In Inbox.Items
   strSubject = Item.Subject
    f = strSubject
    Rem MkDir ("Z:\OPERATIO\AS400_Report\" & f)
    For Each Atmt In Item.Attachments
        FileName = "Z:\OPERATIO\AS400_Reports\" & f & "\" & Atmt.FileName
        Atmt.SaveAsFile FileName
        i = i + 1


    'commented out and added rule option to delete the item
    Next Atmt
    'Item.Delete

    GetAttachments_exit:
     Set Atmt = Nothing
     Set Item = Nothing
     Set ns = Nothing
     Exit Sub

    GetAttachments_err:
     MsgBox "An unexpected error has occurred." _
     & vbCrLf & "Please note and report the following information." _
     & vbCrLf & "Macro Name: SaveAttachments2" _
     & vbCrLf & "Error Number: " & Err.Number _
     & vbCrLf & "Error Description: " & Err.Description _
     , vbCritical, "Error!"
     Resume GetAttachments_exit
    'added next because of compile error
    Next
    End Sub

Answer 1

You cannot change standalone VBA by simply adding (mail As Outlook.MailItem).

Public Sub SaveAttachments2(mail As Outlook.mailItem)

    Dim Atmt As attachment
    Dim FileName As String
    Dim f As String

    f = Trim(mail.Subject) ' Removes spaces at ends. This is a big problem.

    On Error Resume Next
    MkDir ("Z:\OPERATIO\AS400_Report\" & f) ' Creates a folder if it does not exist

    On Error GoTo GetAttachments_err

    For Each Atmt In mail.Attachments
       FileName = "Z:\OPERATIO\AS400_Reports\" & f & "\" & Atmt.FileName

        Atmt.SaveAsFile FileName
        ' Fails on subjects with illegal characters.
        ' For example when RE: and FW: in the subject the folder cannot be created.

    Next Atmt

GetAttachments_exit:
     Exit Sub

GetAttachments_err:
     MsgBox "An unexpected error has occurred." _
     & vbCrLf & "Please note and report the following information." _
     & vbCrLf & "Macro Name: SaveAttachments2" _
     & vbCrLf & "Error Number: " & Err.Number _
     & vbCrLf & "Error Description: " & Err.Description _
     , vbCritical, "Error!"
     Resume GetAttachments_exit

End Sub

See here if illegal characters cause problems creating folders. Save mail with subject as filename