Page 3 of 4 FirstFirst 1234 LastLast
Results 21 to 30 of 32

Thread: Vba to move emails from Inbox to personal folder

  1. #21
    Board Regular Pranesh's Avatar
    Join Date
    Jun 2014
    Posts
    207
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Vba to move emails from Inbox to personal folder

    Quote Originally Posted by Domenic View Post
    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.




    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.

    Hi Domenic,


    As you said i took post#6 and run it but it was not working and found that the receipient address is the only issue. Senderemailaddress is not only taking the email id or name, but before that there are someother things included. So i copied that entirely and run the macro and it worked perfectly.


    Thank you so much for your patience and help till now. I need few more help from you.


    1, Instead of searching the entire inbox i need to pick only the specific date to search for emails. For example if i give 05/27/2019 in cell A1 it should look for emails received only on that date and move those mails and created table.

    2, Usually i receive those mailers between 9-10AM and i might run this Macro by 11AM. By that time sometimes there would be some queries raised on any of the emails and there would be reply from the DL with subject starting as RE: or FW: so the macro moves the RE: & FW: emails as well and that should not happen. Basically it should move only mails with subject not starting as RE: or FW:

    3, Need to include "S.No" as 1st column in table followed by email subject and received time.

    4, In addition to it i need one more column to be included. There are few emails which will be received on 8:30AM daily at times due to some technical issue the email would have received by 9:30 or 10:00AM. I have the list of emails(Column A) and the time they usually receive(Column B) in the excel sheet where i run this macro. I need the macro to compare the received time which is updated in table(Macro output) with the usuall receive time i have in the excell and should give status as "On Time" if it has received 30min prior the original receive time or 30min after the original receive time, else it should update as "__Min Delay"(For example - if the mail received time is updated in excel as 8:30AM and if the mail is received between 8:00AM to 9:00AM it should be "On Time". If the email is received after 9:01AM then the status should be updated as "__Min Delay" based on the delay time.


    Sorry to disturb you a lot. Thanks for helping me. Hope you would help me with this additional request as well.

  2. #22
    MrExcel MVP
    Join Date
    Mar 2004
    Location
    Canada
    Posts
    18,722
    Post Thanks / Like
    Mentioned
    29 Post(s)
    Tagged
    5 Thread(s)

    Default Re: Vba to move emails from Inbox to personal folder

    I've only had a chance to address #1 and #2 , so I suggested you start a new thread for help with #3 and #4 . Here's the code, which has been amended to address #1 and #2 ...

    HTML Code:
    Sub MoveAndEmailReport()
    
        Dim olApp As Object
        Dim olNS As Object
        Dim olInBox As Object
        Dim olRestrictedItems As Object
        Dim strFilter1 As String
        Dim strFilter2 As String
        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")
        
        'Set inbox
        Set olInBox = olNS.GetDefaultFolder(6) 'olFolderInbox
        
        'Filter items for date specified in cell A1 in Sheet1 (change the sheet reference accordingly)
        strFilter1 = "[ReceivedTime] >= '" & Format(Worksheets("Sheet1").Range("A1").Value, "ddddd h:nn AMPM") & "'"
        strFilter2 = "[ReceivedTime] < '" & Format(Worksheets("Sheet1").Range("A1").Value + 1, "ddddd h:nn AMPM") & "'"
        Set olRestrictedItems = olInBox.Items.Restrict(strFilter1 & " And " & strFilter2)
        
        '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 = olRestrictedItems.Count To 1 Step -1
            Set olItem = olRestrictedItems(itemIndex)
            If TypeName(olItem) = "MailItem" Then
                If olItem.SenderEmailAddress = "janedoe@example.com" Then 'change the email address accordingly
                    If UCase(Left(olItem.Subject, 3)) <> "RE:" And UCase(Left(olItem.Subject, 3)) <> "FW:" Then
                        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
            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 olInBox = Nothing
        Set olRestrictedItems = 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
    Hope this helps!

  3. #23
    Board Regular Pranesh's Avatar
    Join Date
    Jun 2014
    Posts
    207
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Vba to move emails from Inbox to personal folder

    Quote Originally Posted by Domenic View Post
    I've only had a chance to address #1 and #2 , so I suggested you start a new thread for help with #3 and #4 . Here's the code, which has been amended to address #1 and #2 ...

    HTML Code:
    Sub MoveAndEmailReport()
    
        Dim olApp As Object
        Dim olNS As Object
        Dim olInBox As Object
        Dim olRestrictedItems As Object
        Dim strFilter1 As String
        Dim strFilter2 As String
        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")
        
        'Set inbox
        Set olInBox = olNS.GetDefaultFolder(6) 'olFolderInbox
        
        'Filter items for date specified in cell A1 in Sheet1 (change the sheet reference accordingly)
        strFilter1 = "[ReceivedTime] >= '" & Format(Worksheets("Sheet1").Range("A1").Value, "ddddd h:nn AMPM") & "'"
        strFilter2 = "[ReceivedTime] < '" & Format(Worksheets("Sheet1").Range("A1").Value + 1, "ddddd h:nn AMPM") & "'"
        Set olRestrictedItems = olInBox.Items.Restrict(strFilter1 & " And " & strFilter2)
        
        '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 = olRestrictedItems.Count To 1 Step -1
            Set olItem = olRestrictedItems(itemIndex)
            If TypeName(olItem) = "MailItem" Then
                If olItem.SenderEmailAddress = "janedoe@example.com" Then 'change the email address accordingly
                    If UCase(Left(olItem.Subject, 3)) <> "RE:" And UCase(Left(olItem.Subject, 3)) <> "FW:" Then
                        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
            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 olInBox = Nothing
        Set olRestrictedItems = 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
    Hope this helps!
    Hi Domenic,


    Thank you so much for your help till now. The code works perfectly for the #1 & #2 . I will create a new thread for the remaining.


    Meanwhile I'm trying to just copy the table which is defined as strHtmlbody to the excel sheet where i run this. But im unable to paste it. Below is the code which i use. Any suggestions to work it out.

    Code:
    tw.Activate
            Sheet1.Select
            Range("A3").Select
            Selection.Value = strHtmlBody

  4. #24
    MrExcel MVP
    Join Date
    Mar 2004
    Location
    Canada
    Posts
    18,722
    Post Thanks / Like
    Mentioned
    29 Post(s)
    Tagged
    5 Thread(s)

    Default Re: Vba to move emails from Inbox to personal folder

    I'm not sure what you mean by "unable to paste it". If you want to copy the table itself to Excel, without the html code, try...

    Code:
    olMail.GetInspector.WordEditor.Tables(1).Range.Copy
    Sheet1.Paste Sheet1.Range("A3")

  5. #25
    Board Regular Pranesh's Avatar
    Join Date
    Jun 2014
    Posts
    207
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Vba to move emails from Inbox to personal folder

    Quote Originally Posted by Domenic View Post
    I'm not sure what you mean by "unable to paste it". If you want to copy the table itself to Excel, without the html code, try...

    Code:
    olMail.GetInspector.WordEditor.Tables(1).Range.Copy
    Sheet1.Paste Sheet1.Range("A3")
    Hi Domenic,


    This is what i expected. Your code works perfect. You made my work easier with help of your code. Thank you so much for all your time and help till now. I hope and wish your help will continue when again i post a new thread.

  6. #26
    MrExcel MVP
    Join Date
    Mar 2004
    Location
    Canada
    Posts
    18,722
    Post Thanks / Like
    Mentioned
    29 Post(s)
    Tagged
    5 Thread(s)

    Default Re: Vba to move emails from Inbox to personal folder

    You're very welcome!

    Cheers!

  7. #27
    Board Regular Pranesh's Avatar
    Join Date
    Jun 2014
    Posts
    207
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Vba to move emails from Inbox to personal folder

    Quote Originally Posted by Domenic View Post
    You're very welcome!

    Cheers!
    Hi Domenic,


    Sorry to disturb you again.


    Everything is working fine in this Macro. I have one small correction to be made. Please help me if you can.


    Now if i give the date as 6/26/2019 the macro pulls all the emails received on that datel. I need a correction here. If i give date as 6/26/2019 1:00 PM it should move the mails received on 6/26/2019 from 12:00 AM to till 1:00 PM. If i update date as 6/26/2019 2:00 PM then it should move the mails received on 6/26/2019 from 2:00 PM to 6/26/2019 11:59 PM.

    Thanks in advance for your help.

  8. #28
    MrExcel MVP
    Join Date
    Mar 2004
    Location
    Canada
    Posts
    18,722
    Post Thanks / Like
    Mentioned
    29 Post(s)
    Tagged
    5 Thread(s)

    Default Re: Vba to move emails from Inbox to personal folder

    Let's say that A1 contains 6/26/2019 1:00 PM. To get the starting time of 6/26/2019 12:00 AM, you would use the Int function...

    Code:
    Int(Worksheets("Sheet1").Range("A1").Value)


    And for the ending time of 6/26/2019 1:00 PM, you would simply use...

    Code:
    Worksheets("Sheet1").Range("A1").Value


    Therefore your filters would be as follows...

    Code:
        'Filter items for date specified in cell A1
        strFilter1 = "[ReceivedTime] >= '" & Format(Int(Worksheets("Sheet1").Range("A1").Value), "ddddd h:nn AMPM") & "'"
        strFilter2 = "[ReceivedTime] < '" & Format(Worksheets("Sheet1").Range("A1").Value, "ddddd h:nn AMPM") & "'"


    Hope this helps!

  9. #29
    Board Regular Pranesh's Avatar
    Join Date
    Jun 2014
    Posts
    207
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Vba to move emails from Inbox to personal folder

    Quote Originally Posted by Domenic View Post
    Let's say that A1 contains 6/26/2019 1:00 PM. To get the starting time of 6/26/2019 12:00 AM, you would use the Int function...

    Code:
    Int(Worksheets("Sheet1").Range("A1").Value)


    And for the ending time of 6/26/2019 1:00 PM, you would simply use...

    Code:
    Worksheets("Sheet1").Range("A1").Value


    Therefore your filters would be as follows...

    Code:
        'Filter items for date specified in cell A1
        strFilter1 = "[ReceivedTime] >= '" & Format(Int(Worksheets("Sheet1").Range("A1").Value), "ddddd h:nn AMPM") & "'"
        strFilter2 = "[ReceivedTime] < '" & Format(Worksheets("Sheet1").Range("A1").Value, "ddddd h:nn AMPM") & "'"


    Hope this helps!

    Hi Domenic,


    Thank you so much for your response and help.


    I applied the code you provided it is moving emails received till 1:00 AM.


    I think i didnt clearly explain what im looking for. Actually i will run this macro twice a day. Morning between 7 to 11 i will receive a set of emails and between 3:00PM to 7:00PM i will receive few set of emails so i run this twice a day.


    If im on leave i will run it the next day by updating previous date in Range("A1") and the macro will move all the emails received through out the day and thats is why i need a split in moving this email.


    My sugesstion is if i have date as 6/27/2019 in Range("A1") and "Morning" in Range("A2") then macro should move the emails received between 6/27/2019 12:00 AM to 02:00 PM. If if update Range("A2") as "Evening" then macro should move emails received on 6/27/2019 between 02:01 PM to 11:59 PM.

    Thanks again for your help.

  10. #30
    MrExcel MVP
    Join Date
    Mar 2004
    Location
    Canada
    Posts
    18,722
    Post Thanks / Like
    Mentioned
    29 Post(s)
    Tagged
    5 Thread(s)

    Default Re: Vba to move emails from Inbox to personal folder

    In that case, try the following...

    Code:
        'Filter items for date specified in cell A1
        If UCase(Worksheets("Sheet1").Range("A2")) = "MORNING" Then
            strFilter1 = "[ReceivedTime] >= '" & Format(Worksheets("Sheet1").Range("A1").Value, "ddddd h:nn AMPM") & "'"
            strFilter2 = "[ReceivedTime] < '" & Format(Worksheets("Sheet1").Range("A1").Value + TimeValue("2:00 PM"), "ddddd h:nn AMPM") & "'"
        ElseIf UCase(Worksheets("Sheet1").Range("A2")) = "EVENING" Then
            strFilter1 = "[ReceivedTime] >= '" & Format(Worksheets("Sheet1").Range("A1").Value + TimeValue("2:00 PM"), "ddddd h:nn AMPM") & "'"
            strFilter2 = "[ReceivedTime] < '" & Format(Worksheets("Sheet1").Range("A1").Value + 1, "ddddd h:nn AMPM") & "'"
        End If
    Last edited by Domenic; Jun 27th, 2019 at 02:18 PM.

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •