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
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.
- 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!"
- MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
- End If
- ' Clear memory
- Set Atmt = Nothing
- Set Item = Nothing
- Set ns = Nothing
- Set appOl = Nothing
- Exit Sub
- ' Handle errors
- 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