Vba to move emails from Inbox to personal folder

[Pranesh]

Hi,

I receive 20 to 25 emails a day from a common mail box daily to my Outlook 2016. I will then move those emails to a personal folder named "Daily email1" & "Daily email 2" based on email subject.

I want this to be automated. Whenever I get those emails I want a button to run a code which should move those emails to respective folder based on email subject. Once that is done I need Macro to prepare a report to say how many emails has been received from that email box and need a list of email subject with the mail received time in body of the email which should be sent to a user.

I searched online for VBA codes but no luck. Can someone help me.

 

[Pranesh]

The reason I asked you to replace that line is so that the comparison would not be case-sensitive. So when you change the email address in the code to the actual email address, simply make sure that the email address is all capitals. This way it won't matter how the address appears in the email itself.

Hi Domenic,

I have changed the code and updated the email address with capitals, but still getting no emails received error.

 

[Domenic]

First, let's make sure that you're specifying the correct email address in your code. Go to the folder that contains your emails. Then, double-click one of the target emails so that it opens up and displays. Now open the Visual Basic Editor (Alt+F11) within Outlook. Then, display the Immediate window (Alt+G). Then, type the following line in the Immediate window and press Enter...

? activeinspector.CurrentItem.senderemailaddress

It should match the email address specified in the code, except that the one in the code will be all capitals. Does it match?

 

[Pranesh]

First, let's make sure that you're specifying the correct email address in your code. Go to the folder that contains your emails. Then, double-click one of the target emails so that it opens up and displays. Now open the Visual Basic Editor (Alt+F11) within Outlook. Then, display the Immediate window (Alt+G). Then, type the following line in the Immediate window and press Enter...

? activeinspector.CurrentItem.senderemailaddress

It should match the email address specified in the code, except that the one in the code will be all capitals. Does it match?

Hi Domenic,


I applied your code in Outlook and as a output i got the email name. For example my email ID is EMAILSUPPORT@ABC.COM after applying your code i it gave me the email name "EMAILSUPPORT"


I tried both with email name and email address in the below code but again getting "No emails received" msg box.

If UCase(olItem.SenderEmailAddress) = "[EMAIL="EMAILSUPPORT@ABC.COM"]EMAILSUPPORT@ABC.COM[/EMAIL]" Then
If UCase(olItem.SenderEmailAddress) = "EMAILSUPPORT" Then

 

[Domenic]

I applied your code in Outlook and as a output i got the email name. For example my email ID is EMAILSUPPORT@ABC.COM after applying your code i it gave me the email name "EMAILSUPPORT"

I don't understand why it returns the sender's name, instead of the actual sender's email address. In any case, I have re-read your original post, and I see that you said that the emails are located within a common mail box. So it looks like they're not located in your default inbox. So we're probably referencing the wrong mail box.

Try this. Go to Outlook, select the folder that contains your emails (select just the folder, not an email), and then within Outlook go to the Visual Basic Editor (Alt+F11), type the following line of code and press ENTER...

? ActiveExplorer.CurrentFolder.FolderPath

It should return something like this...

\\MyFolder\Inbox

Then simply change the line setting the inbox accordingly. With this example, it would be...

Set olInBox = olNS.Folders("MyFolder").Folders("Inbox")

Then, hopefully, .senderEmailAddress will return the actual sender's email address, in which case you should use "EMAILSUPPORT@ABC.COM". Otherwise, if it returns the sender's name, use "EMAILSUPORT" instead.

Does this help?

 

[Pranesh]

I don't understand why it returns the sender's name, instead of the actual sender's email address. In any case, I have re-read your original post, and I see that you said that the emails are located within a common mail box. So it looks like they're not located in your default inbox. So we're probably referencing the wrong mail box.

Try this. Go to Outlook, select the folder that contains your emails (select just the folder, not an email), and then within Outlook go to the Visual Basic Editor (Alt+F11), type the following line of code and press ENTER...

? ActiveExplorer.CurrentFolder.FolderPath

It should return something like this...

\\MyFolder\Inbox

Then simply change the line setting the inbox accordingly. With this example, it would be...

Set olInBox = olNS.Folders("MyFolder").Folders("Inbox")

Then, hopefully, .senderEmailAddress will return the actual sender's email address, in which case you should use "EMAILSUPPORT@ABC.COM". Otherwise, if it returns the sender's name, use "EMAILSUPORT" instead.

Does this help?

Hi Domenic,
I will receive the emails from a common Mail box, but i dont have that common mail box in my Outlook. So as of now the emails has been received in my Inbox.


I also opened an email of my friend which was in my Inbox and applied your code but instead of his email ID and getting his name.

 

[Domenic]

Yeah, I'm not sure why you're getting his name, instead of his email address, when using .senderEmailAddress. In that case, though, simply test for his name.

 

[Pranesh]

Yeah, I'm not sure why you're getting his name, instead of his email address, when using .senderEmailAddress. In that case, though, simply test for his name.

Hi Domenic,

Tested with name as well but not working. If you can try with some dummy data might help. I'm not sure how to fix it.

 

[Domenic]

I still think the problem is that we're referencing the wrong folder. You said that it's a common mail box, so I guess it's a shared folder. I searched Google, and it seems that we would need to change how we access this shared folder. I haven't been able to test it, but I think that the following code should work. Any changes or additions are marked in red. And make the necessary changes, where indicated. Also, don't forget to remove the spaces after each occurrence of angled brackets (<). Please let me know whether this helps.

Option Explicit

Sub MoveAndEmailReport()

    Dim olApp As Object
    Dim olNS As Object
    [COLOR=#ff0000]Dim olRecipient As Object
    Dim olSharedInbox As Object[/COLOR]
    Dim olMoveToFolder As Object
    Dim olItem As Object
    Dim olMail As Object
    Dim strHtmlContents As String
    Dim strHtmlBody As String
    Dim blnStarted As Boolean
    Dim emailCount As Long
    Dim itemIndex As Long
    
    On Error Resume Next
    'Get Outlook, if its already running
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then
        'Outlook wasn't already running, so start it
        Set olApp = CreateObject("Outlook.Application")
        If olApp Is Nothing Then
            MsgBox "Unable to open Outlook!", vbExclamation
            Exit Sub
        End If
        blnStarted = True
    End If
    On Error GoTo errHandler
    
    'Set namespace
    Set olNS = olApp.GetNamespace("MAPI")
    
    [COLOR=#ff0000]'Set recipient, it can be a string representing the display name,
    'the alias, or email address of the recipient (change accordingly)
    Set olRecipient = olNS.CreateRecipient("pranesh@email.com")
    
    'Resolve the Recipient object against the address book
    olRecipient.Resolve
    
    'Check whether Recipient object is resolved
    If Not olRecipient.Resolved Then
        MsgBox "Unable to resolve Recipient object!", vbExclamation
        GoTo exitHandler
    End If
    
    'Set the shared default inbox
    Set olSharedInbox = olNS.GetSharedDefaultFolder(olRecipient, 6) '6=olFolderInbox[/COLOR]
    
    'Set folder to move emails to
    Set olMoveToFolder = olNS.Folders("DailyMail").Folders("Daily Mailers")
    
    'Loop through each item in inbox, move items that meet the criteria to their
    'respective folder, collect relevant data in html table format, and keep track of
    'number of emails that met criteria and were moved
    strHtmlContents = ""
    emailCount = 0
    For itemIndex = olSharedInbox.Items.Count To 1 Step -1
        Set olItem = olSharedInbox.Items(itemIndex)
        If TypeName(olItem) = "MailItem" Then
            If olItem.SenderEmailAddress = "janedoe@example.com" Then 'change the email address accordingly
                strHtmlContents = strHtmlContents & vbCrLf & "< tr>"
                strHtmlContents = strHtmlContents & vbCrLf & "< td>" & olItem.Subject & "< /td>"
                strHtmlContents = strHtmlContents & vbCrLf & "< td>" & olItem.receivedtime & "< /td>"
                strHtmlContents = strHtmlContents & vbCrLf & "< /tr>"
                olItem.Move olMoveToFolder
                emailCount = emailCount + 1
            End If
        End If
    Next itemIndex
    
    'If one or more emails met the criteria and were moved, add the necessary html code
    'to complete the formatting for the html table, and then create a new email with the data
    'collected and send it to the specified user
    If emailCount > 0 Then
        strHtmlBody = "< table width=100% border=1 cellpadding=3>"
        strHtmlBody = strHtmlBody & "< tr>"
        strHtmlBody = strHtmlBody & vbCrLf & "< th width=70% align=left>Subject< /th>"
        strHtmlBody = strHtmlBody & vbCrLf & "< th align=left>Received Time< /th>"
        strHtmlBody = strHtmlBody & vbCrLf & "< /tr>"
        strHtmlBody = strHtmlBody & vbCrLf & strHtmlContents
        strHtmlBody = strHtmlBody & vbCrLf & "< /table>"
        Set olMail = olApp.CreateItem(0)
        With olMail
            .To = "johnsmith@example.com" 'change the email address accordingly
            .Subject = "List of emails received" 'change the subject accordingly
            .htmlbody = "< p>Number of emails received: " & emailCount & "< /p>"
            .htmlbody = .htmlbody & strHtmlBody
            .display 'to display email instead of sending it
            '.send 'to send email instead of displaying it
        End With
        MsgBox emailCount & " email(s) received and moved, and report sent.", vbInformation
    Else
        MsgBox "No emails received.", vbInformation
    End If
    
exitHandler:
    'If Outlook was started, close it
    'Uncomment next 3 lines when emails are actual being sent
    'If blnStarted Then
        'olApp.Quit
    'End If
    
    Set olApp = Nothing
    Set olNS = Nothing
    Set olSharedInbox = Nothing
    Set olMoveToFolder = Nothing
    Set olItem = Nothing
    Set olMail = Nothing
    
    Exit Sub
    
errHandler:
    MsgBox "Error " & Err.Number & ":" & vbCrLf & vbCrLf & Err.Description, vbCritical, "Error"
    Resume exitHandler
    
End Sub

 

[Pranesh]

I still think the problem is that we're referencing the wrong folder. You said that it's a common mail box, so I guess it's a shared folder. I searched Google, and it seems that we would need to change how we access this shared folder. I haven't been able to test it, but I think that the following code should work. Any changes or additions are marked in red. And make the necessary changes, where indicated. Also, don't forget to remove the spaces after each occurrence of angled brackets (<). Please let me know whether this helps.

Option Explicit

Sub MoveAndEmailReport()

    Dim olApp As Object
    Dim olNS As Object
    [COLOR=#ff0000]Dim olRecipient As Object
    Dim olSharedInbox As Object[/COLOR]
    Dim olMoveToFolder As Object
    Dim olItem As Object
    Dim olMail As Object
    Dim strHtmlContents As String
    Dim strHtmlBody As String
    Dim blnStarted As Boolean
    Dim emailCount As Long
    Dim itemIndex As Long
    
    On Error Resume Next
    'Get Outlook, if its already running
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then
        'Outlook wasn't already running, so start it
        Set olApp = CreateObject("Outlook.Application")
        If olApp Is Nothing Then
            MsgBox "Unable to open Outlook!", vbExclamation
            Exit Sub
        End If
        blnStarted = True
    End If
    On Error GoTo errHandler
    
    'Set namespace
    Set olNS = olApp.GetNamespace("MAPI")
    
    [COLOR=#ff0000]'Set recipient, it can be a string representing the display name,
    'the alias, or email address of the recipient (change accordingly)
    Set olRecipient = olNS.CreateRecipient("pranesh@email.com")
    
    'Resolve the Recipient object against the address book
    olRecipient.Resolve
    
    'Check whether Recipient object is resolved
    If Not olRecipient.Resolved Then
        MsgBox "Unable to resolve Recipient object!", vbExclamation
        GoTo exitHandler
    End If
    
    'Set the shared default inbox
    Set olSharedInbox = olNS.GetSharedDefaultFolder(olRecipient, 6) '6=olFolderInbox[/COLOR]
    
    'Set folder to move emails to
    Set olMoveToFolder = olNS.Folders("DailyMail").Folders("Daily Mailers")
    
    'Loop through each item in inbox, move items that meet the criteria to their
    'respective folder, collect relevant data in html table format, and keep track of
    'number of emails that met criteria and were moved
    strHtmlContents = ""
    emailCount = 0
    For itemIndex = olSharedInbox.Items.Count To 1 Step -1
        Set olItem = olSharedInbox.Items(itemIndex)
        If TypeName(olItem) = "MailItem" Then
            If olItem.SenderEmailAddress = "janedoe@example.com" Then 'change the email address accordingly
                strHtmlContents = strHtmlContents & vbCrLf & "< tr>"
                strHtmlContents = strHtmlContents & vbCrLf & "< td>" & olItem.Subject & "< /td>"
                strHtmlContents = strHtmlContents & vbCrLf & "< td>" & olItem.receivedtime & "< /td>"
                strHtmlContents = strHtmlContents & vbCrLf & "< /tr>"
                olItem.Move olMoveToFolder
                emailCount = emailCount + 1
            End If
        End If
    Next itemIndex
    
    'If one or more emails met the criteria and were moved, add the necessary html code
    'to complete the formatting for the html table, and then create a new email with the data
    'collected and send it to the specified user
    If emailCount > 0 Then
        strHtmlBody = "< table width=100% border=1 cellpadding=3>"
        strHtmlBody = strHtmlBody & "< tr>"
        strHtmlBody = strHtmlBody & vbCrLf & "< th width=70% align=left>Subject< /th>"
        strHtmlBody = strHtmlBody & vbCrLf & "< th align=left>Received Time< /th>"
        strHtmlBody = strHtmlBody & vbCrLf & "< /tr>"
        strHtmlBody = strHtmlBody & vbCrLf & strHtmlContents
        strHtmlBody = strHtmlBody & vbCrLf & "< /table>"
        Set olMail = olApp.CreateItem(0)
        With olMail
            .To = "johnsmith@example.com" 'change the email address accordingly
            .Subject = "List of emails received" 'change the subject accordingly
            .htmlbody = "< p>Number of emails received: " & emailCount & "< /p>"
            .htmlbody = .htmlbody & strHtmlBody
            .display 'to display email instead of sending it
            '.send 'to send email instead of displaying it
        End With
        MsgBox emailCount & " email(s) received and moved, and report sent.", vbInformation
    Else
        MsgBox "No emails received.", vbInformation
    End If
    
exitHandler:
    'If Outlook was started, close it
    'Uncomment next 3 lines when emails are actual being sent
    'If blnStarted Then
        'olApp.Quit
    'End If
    
    Set olApp = Nothing
    Set olNS = Nothing
    Set olSharedInbox = Nothing
    Set olMoveToFolder = Nothing
    Set olItem = Nothing
    Set olMail = Nothing
    
    Exit Sub
    
errHandler:
    MsgBox "Error " & Err.Number & ":" & vbCrLf & vbCrLf & Err.Description, vbCritical, "Error"
    Resume exitHandler
    
End Sub

Hi Domenic,


It is not a shared folder. I will explain it clearly now. I receive emails from a Distribution List(DL). In that DL there will be few users mail IDs who are part of that DL, and there will be a common Mail ID for that particular DL. If we send emails to that DL it will reach to all the recipients who are part of that list.


So these emails are received to me from that DL to my Inbox. Then i need to find out those emails and move them to a specific folder and send a mail stating the list of emails received which is basically the subject of the email and the time it was received.

Do i need to change anything in the below code. What does "MailItem" means. When code is executed it is showing as nothing in it.

If TypeName(olItem) = "MailItem" Then

 

[Domenic]

So these emails are received to me from that DL to my Inbox.

In that case, the code in Post #6 in this thread should work. Can you confirm whether the "Inbox" is your default inbox? Or whether it's an inbox within a personal folder? It might help if you posted an image of the folder structure in Outlook.

Do i need to change anything in the below code. What does "MailItem" means.

If TypeName(olItem) = "MailItem" Then

That line checks whether the item is a mail item, meeting item, etc. It resolves to True if the item is a mail item. If you stop your code at that line and move your cursor over olItem, it should display the subject.