Public Sub Save_APPS(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim vExt As Variant
    saveFolder = "P:\Data\"
    For Each objAtt In itm.Attachments
        If InStr(objAtt.fileName, ".xls") Then
            vExt = Split(objAtt.fileName, Chr(46))
            objAtt.SaveAsFile saveFolder & "\" & _
                              Left(objAtt.fileName, 5) & _
                              Chr(46) & vExt(UBound(vExt))
        End If
    Next
    Set objAtt = Nothing
End Sub