Sub GetAttachments_From_Inbox()
On Error GoTo GetAttachments_err
Dim appOl As New Outlook.Application
Dim ns As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim myDestFolder As Outlook.MAPIFolder
Dim Item As Object
'Dim Item As Outlook.Items
Dim Atmt As Outlook.Attachment
Dim FileName As String
Dim i As Integer
Dim iLoop As Integer
Dim sender As String
Dim bankName As String
Dim ext As String
Dim Items As Outlook.Items
Dim oc As Object
Dim moveEmail As Boolean
Set ns = appOl.GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set Item = Inbox.Items
Set myDestFolder = Inbox.Folders("Personal Mail")
'Set oc = Application.ActiveInspector.CurrentItem
i = 0
iLoop = 0
' Check Inbox for messages and exit if none found
If Inbox.Items.Count = 0 Then
' ' MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
' Check each message for attachments
'MsgBox " Size of inbox " + Inbox.Items.Count + " "
For iLoop = 1 To Inbox.Items.Count
'MsgBox "Loop -> " + iLoop
For Each Item In Inbox.Items
moveEmail = False
' Save any attachments found
For Each Atmt In Item.Attachments
If UCase(Atmt.FileName) Like "Export*" Or _
UCase(Atmt.FileName) Like "Report*" Or _
UCase(Atmt.FileName) Like "Update" Or _
UCase(Atmt.FileName) Like "Sales*" Or _
FileName = "D:\Attachments\" & Atmt.FileName
Atmt.SaveAsFile FileName
moveEmail = True
'Exit For
'Item.Move myDestFolder
i = i + 1
'Set Item = Item.FindNext
End If
Next Atmt
If moveEmail Then
' now move email to personal folder
Item.Move myDestFolder
End If
Next Item
iLoop = iLoop + 1
Next
' Show summary message
If i > 0 Then
'MsgBox "I found " & i & " attached files." _
& vbCrLf & "I have saved them into the D:\Attachments folder." _
& vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
Else
' MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Set appOl = Nothing
Exit Sub
' Handle errors
GetAttachments_err:
'MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit
End Sub
