Consulting

Results 1 to 4 of 4

Thread: Code to move to a new folder emails sent or received on a specified day

  1. #1
    VBAX Regular
    Joined
    Oct 2014
    Posts
    95
    Location

    Code to move to a new folder emails sent or received on a specified day

    This was posted to MrExcel in Aug 2014 but received no responses. So I am reposting here.

    In order to compare emails relating to an annual reporting task, I would like to be able to move to a new Outlook folder emails sent or received on a particular day (regardless of year - that is, it would move all emails dated 1 Dec 2000, 1 Dec 2001, 1 Dec 2002, and so on). Ideally I'd like the user to be able to enter their chosen date in a dialog box. I've adapted the following code but it only deals with sent items, not received, and there's no dialog box. It's not quite right. Many thanks for your input.

    Sub MoveEmail()
    Dim olMAPI As Object    'Outlook.Application
    Dim moveFolder As Object     'Outlook.MAPIFolder
    Dim InItem As Object     'Outlook.MAPIFolder
    Dim MItem As Object     'Outlook.MailItem
    Dim sentDate As Date
    Dim sentDate2 As Date
    Dim myDay As Integer
    Dim i As Integer
       
    Set olMAPI = GetObject("", "Outlook.Application").GetNamespace("MAPI")
    Set InItem = olMAPI.Folders("xtendlink (test)").Folders("Inbox")
    Set moveFolder = olMAPI.Folders("xtendlink (test)").Folders("Inbox").Folders("old")
    Set dltFolder = olMAPI.Folders("xtendlink (test)").Folders("Deleted Items")
    
    i = 0
    
    If InItem.Items.Count = 0 Then
    
    MsgBox InItem.Items.Count
    
        MsgBox "There are no messages in the Referral Folder.", vbInformation, _
               "Nothing Found"
        Exit Sub
        
    End If
    
    Count = InItem.Items.Count
    For i = Count To 1 Step -1
        Set MItem = InItem.Items.Item(i)
            mySub = MItem.Subject
        sentDate = Format(MItem.SentOn, "mm/dd")
            If sentDate = "12/01" Then
            MItem.Move moveFolder
        End If
        
    Next
    Set moveFolder = Nothing
    Set dltFolder = Nothing
    Set InItem = Nothing
    Set MItem = Nothing
    End Sub

  2. #2
    Can we assume that the folder 'Old' already exists as a sub folder of Inbox; that you are running the macro from Excel and not Outlook; and the folder structure is otherwise standard? Then you need something like the following:

    Note that if you are running from Excel, if Outlook is already running it is quicker to use the existing Outlook process rather than create another. If running from Outlook the code can be simplified.

    As you want to process both the inbox and the sent items folders, you will have to process them separately.

    Option Explicit
    Sub MoveEmail()
    Dim oOutlookApp As Object        'Outlook.Object
    Dim olNS As Object        'Outlook.NameSpace
    Dim moveFolder As Object        'Outlook.MAPIFolder
    Dim inFolder As Object        'Outlook.MAPIFolder
    Dim outFolder As Object
    Dim MyReceivedItem As Object        'Outlook.MailItem
    Dim MySentItem As Object
    Dim sentDate As String
    Dim askDate As String
    Dim i As Long, j As Long
    Dim inCount As Long, outCount As Long
    Dim mySub As String
    
        On Error Resume Next
        'Get Outlook if it's running
        Set oOutlookApp = GetObject(, "Outlook.Application")
    
        'Outlook wasn't running, start it from code
        If Err <> 0 Then
            Set oOutlookApp = CreateObject("Outlook.Application")
        End If
        On Error GoTo 0
    
        askDate = InputBox("Enter the date in the format 'mm/dd'", "Process Date", "12/01")
    
        Set olNS = oOutlookApp.GetNamespace("MAPI")
        Set inFolder = olNS.GetDefaultFolder(6)
        Set outFolder = olNS.GetDefaultFolder(5) 'Note the deleted items folder would be (3)
        Set moveFolder = inFolder.Folders("Old")
    
        'Inbox
        inCount = inFolder.Items.Count
            If inCount = 0 Then
            MsgBox "There are no messages in the Inbox Folder.", vbInformation, _
                   "InBox Folder"
            Exit Sub
        End If
    
        For i = inCount To 1 Step -1
            Set MyReceivedItem = inFolder.Items.Item(i)
            sentDate = Format(MyReceivedItem.SentOn, "mm/dd")
            If sentDate = askDate Then
                mySub = MyReceivedItem.Subject
                MyReceivedItem.Move moveFolder
            End If
        Next i
    
        'Sent Folder
        outCount = outFolder.Items.Count
        If outCount = 0 Then
            MsgBox "There are no messages in the Sent Items folder.", vbInformation, _
                   "Sent Folder"
            Exit Sub
        End If
    
        For j = outCount To 1 Step -1
            Set MySentItem = outFolder.Items.Item(j)
            sentDate = Format(MySentItem.SentOn, "mm/dd")
            If sentDate = askDate Then
                mySub = MySentItem.Subject
                MySentItem.Move moveFolder
            End If
        Next j
    
        Set oOutlookApp = Nothing
        Set olNS = Nothing
        Set moveFolder = Nothing
        Set inFolder = Nothing
        Set outFolder = Nothing
        Set MyReceivedItem = Nothing
        Set MySentItem = Nothing
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    I'd like the user to be able to enter their chosen date in a dialog box.
    you could use an inputbox, but better to put a monthview or other date control on a userform

    you can test to see if this works for you, untested, so may contains some code errors or typos
    inputdate = InputBox("enter date to move")
    Set inb = GetNamespace("mapi").GetDefaultFolder(olFolderInbox)
    Set dest = inb.Folders("test")
    For y = 0 To -10 Step -1
        mydate = CDate(inputdate) + DateSerial(y, 0, 0)
        nxtday = CDate(mydate) + 1
        Set itms = inb.Items
        Set itms = itms.Restrict("[receivedtime] > '" & mydate & "' and [receivedtime] < '" & nxtday & "'")
        If itms.Count > 0 Then
            For i = itms.Count To 1 Step -1
                Set itm = itms(i)
                itm.Move dest
            Next
        End If
    Next
    change folders to suit, change max value for y to the number of years you want to move emails, for a specific day, starting from the year entered by the user and working back (10 years specified above, but can be any value)

  4. #4
    VBAX Regular
    Joined
    Oct 2014
    Posts
    95
    Location
    Many thanks for your replies. Sorry for the delay in acknowledging - I've been sidetracked unavoidably but I will certainly use these.

    Thanks again.

Posting Permissions

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