VBA Outlook rule to Run Script is not completing

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

niton niton · Accepted Answer · 2014-07-10T20:56:19

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

VBA Outlook rule to Run Script is not completing

1 Answers