VBA Outlook rule to Run Script is not completing - vba

Question

I'm have trouble with this macro/script that doesn't completely run via email rule
I have an outlook rule that looks for an email with a subject then move the email to a subfolder then runs a script that move the email attachment to a folder on the C drive and then deletes the original email from the subfolder
Everything seem to be setup correctly, security is ok, and the macro runs as a macro outside the rule It's just the rule doesn't run the script, here is the script I'm using
Sub Get_SOH_All(MyMail As MailItem)
On Error GoTo SaveAttachmentsToFolder_err
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("DATA DUMP") ' Enter correct subfolder name.
i = 0
If Len(Dir("c:\DATA DUMP\Stock On Hand", vbDirectory)) = 0 Then
MkDir "c:\DATA DUMP\Stock On Hand"
End If
For Each item In SubFolder.Items
For Each Atmt In item.Attachments
If Right(Atmt.FileName, 3) = "csv" Then
FileName = "C:\DATA DUMP\Stock On Hand\"
Atmt.SaveAsFile FileName & "Stock_On_Hand_All.csv"
item.Delete
i = i + 1
End If
Next Atmt
Next item
SaveAttachmentsToFolder_exit:
Set Atmt = Nothing
Set item = Nothing
Set ns = Nothing
Exit Sub
SaveAttachmentsToFolder_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information to Jarrod Hall." _
& vbCrLf & "Macro Name: GetAttachmentsSOH" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachmentsToFolder_exit
End Sub

Answer 1

The code in a script is normally used on one item not multiple.
The mail is to be deleted so you can drop the part of the rule that moves the mail and try this.
Sub Get_SOH_All(MyMail As MailItem)
On Error GoTo SaveAttachmentsToFolder_err
Dim Atmt As Attachment
Dim FileName As String
If Len(Dir("c:\DATA DUMP\Stock On Hand", vbDirectory)) = 0 Then
MkDir "c:\DATA DUMP\Stock On Hand"
End If
For Each Atmt In MyMail.Attachments
If Right(Atmt.FileName, 3) = "csv" Then
FileName = "C:\DATA DUMP\Stock On Hand\"
Atmt.SaveAsFile FileName & "Stock_On_Hand_All.csv"
MyMail.Delete
End If
Next Atmt
SaveAttachmentsToFolder_exit:
Set MyMail = Nothing
Exit Sub
SaveAttachmentsToFolder_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information to Jarrod Hall." _
& vbCrLf & "Macro Name: GetAttachmentsSOH" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachmentsToFolder_exit
End Sub