Hello Everyone,
I am new to this forum, and new to Outlook VBA as well. It will be great if some one can help me out. Thanks in advance.
My program is suppose to do following functions:
1. Look into Inbox, go through all the emails, look for emails which has attachments.
2. If the email has an attachment then see if it is coming from a known email id, if not then go to next email with
attachment.
3. If the email has attachment and matches with a given email id (defined in the function) then save the attachment as
the senders email id.
Part 1 to 3 is working fine
Part 4 is where I need your help:
4. If the email matches with a given email id then after saving the file, Move the email to a sub folder.
This part 4 is not working properly in my program, it is moving the email twice if email has 2 attachments. Also it is
not going to check all the emails in the Inbox. I have to reset and run the program several time to get the job done. If
someone could help me out it will be very helpful, as I am really stuck on part 4 for a long time.
Also to be done:
5. This part should be able to extract only the excel file from the email attachments as that is what I need, but
presently not able to clear step 4 so didn't got to it yet.
Please let me know if anyone of you could help.
Thanks a lot.
Best Regards.
------------------------------------------------
Option Explicit
Sub GetAttachments_From_Inbox()
On Error GoTo GetAttachments_err
' Declare variables
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 sender As String
Dim ext As String
Dim Items As Outlook.Items
Dim oc As Object
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
' 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
For Each Item In Inbox.Items
' Save any attachments found
For Each Atmt In Item.Attachments
' This filename path must exist! Change folder name as necessary.
sender = Atmt.Parent.SenderEmailAddress
sender = Right(sender, Len(sender) - InStrRev(sender, "="))
ext = Atmt.FileName
ext = Right(ext, Len(ext) - InStrRev(ext, ".") + 1)
FileName = "S:\Loans\Data\For\Outlook\" & get_bank(sender) & ext
'Atmt.SaveAsFile FileName
If get_bank(sender) <> "unknown" Then
Atmt.SaveAsFile FileName
Item.Move myDestFolder
i = i + 1
'Set Item = Item.FindNext
End If
Next Atmt
Next Item
' Show summary message
If i > 0 Then
MsgBox "I found " & i & " attached files." _
& vbCrLf & "I have saved them into the C:\Email 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
Function get_bank(sender As String) As String
Select Case sender
Case "[email protected]"
get_bank = "ABC"
Case Else
get_bank = "unknown"
End Select
End Function
Display More