Find emails in inbox from a specific date and move them to a new folder

问题

I've never made any Outlook VBA before, but I have some experience with Excel VBA. My ultimate goal is to:

1. Search the inbox for all emails from a specific date
2. Create a new subfolder named as the specific date I searched for
3. Move all the emails from that date from the inbox to the subfolder just created

I have been searching for some VBA that can do this, but haven't found anything quite like it yet. Below is the closest I've found. This code is supposed to ask the user the date range they'd like to search, and then export the info to excel. Obviously I dont want to export anything to excel, but I thought the code could be a good place to start to at least find the emails from the date range that I input. However, when I'm testing this, it isnt finding anything within that range even though I have emails in the range.

Here is the code as of now:

Const FILE_NAME = "C:\Users\tboulay\Desktop\Outlook Date Results.xlsx"
Const MACRO_NAME = "Date/Time Search"

Private datBeg As Date, datEnd As Date, timBeg As Date, timEnd As Date
Private excApp As Object, excWkb As Object, excWks As Object, lngRow

Public Sub BeginSearch()
    Dim strRng As String, arrTmp As Variant, arrDat As Variant, arrTim As Variant
    strRng = InputBox("Enter the date/time range to search in the form Date1 to Date2 from Time1 to Time2", MACRO_NAME, "6/1/2018 to 6/2/2018 from 12:00am to 12:00am")
    If strRng = "" Then
        MsgBox "Search cancelled.", vbInformation + vbOKOnly, MACRO_NAME
    Else
        arrTmp = Split(strRng, " from ")
        arrDat = Split(arrTmp(0), " to ")
        arrTim = Split(arrTmp(1), " to ")
        datBeg = arrDat(0)
        datEnd = arrDat(1)
        timBeg = arrTim(0)
        timEnd = arrTim(1)
        If IsDate(datBeg) And IsDate(datEnd) And IsDate(timBeg) And IsDate(timEnd) Then
            Set excApp = CreateObject("Excel.Application")
            Set excWkb = excApp.Workbooks.Add
            Set excWks = excWkb.Worksheets(1)
            excWks.Cells(1, 1) = "Folder"
            excWks.Cells(1, 2) = "Received"
            excWks.Cells(1, 3) = "Sender"
            excWks.Cells(1, 4) = "Subject"
            lngRow = 2
            SearchSub Application.ActiveExplorer.CurrentFolder
            excWks.Columns("A:D").AutoFit
            excWkb.SaveAs FILE_NAME
            excWkb.Close False
            Set excWks = Nothing
            Set excWkb = Nothing
            Set excApp = Nothing
            MsgBox "Search complete.", vbInformation + vbOKOnly, MACRO_NAME
        Else
            MsgBox "The dates/times you entered are invalid or not in the right format.  Please try again.", vbCritical + vbOKOnly, MACRO_NAME
        End If
    End If
End Sub

Private Sub SearchSub(olkFol As Outlook.MAPIFolder)
    Dim olkHit As Outlook.Items, olkItm As Object, olkSub As Outlook.MAPIFolder, datTim As Date
    'If the current folder contains messages, then search it
    If olkFol.DefaultItemType = olMailItem Then
        Set olkHit = olkFol.Items.Restrict("[ReceivedTime] >= '" & Format(datBeg, "ddddd h:nn AMPM") & "' AND [ReceivedTime] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
        For Each olkItm In olkHit
            If olkItm.Class = olMail Then
                datTim = Format(olkItm.ReceivedTime, "h:n:s")
                If datTim >= timBeg And datTim <= timEnd Then
                    excWks.Cells(lngRow, 1) = olkFol.FolderPath
                    excWks.Cells(lngRow, 2) = olkItm.ReceivedTime
                    excWks.Cells(lngRow, 3) = olkItm.SenderName
                    excWks.Cells(lngRow, 4) = olkItm.Subject
                    lngRow = lngRow + 1
                End If
            End If
            DoEvents
        Next
        Set olkHit = Nothing
        Set olkItm = Nothing
    End If
    'Search the subfolders
    For Each olkSub In olkFol.Folders
        SearchSub olkSub
        DoEvents
    Next
    Set olkSub = Nothing
End Sub

For example, I search the range "6/8/2018 to 6/9/2018 from 12:00am to 12:00am", which I have 3 emails in that date range, however it isnt finding anything, so I'm a bit confused as to why not.

If anybody could help me at least get started with finding the emails from a date the user inputs, that would be great! Any extra help with creating a folder and moving the items would be even better, but I can always search out that part separately.

If there is a totally different VBA code that would be simpler and more efficient, then I'm willing to get rid of this code completely. Its just that this is the closest I've even gotten so far.

Much appreciated in advance.

回答1:

Below is the code I ended up using to get the task done. I am still working on making it run faster, but this gets the job done (slower).

It will move the previous workday's emails from a secondary inbox into a newly created subfolder with the date and day.

Sub Move_Yesterdays_Emails()

'***Creates a new folder named yesterdays date under the inbox***

 Dim myNameSpace As Outlook.NameSpace
 Dim strMailboxName As String
 Dim myFolder As Outlook.Folder
 Dim myNewFolder As Outlook.Folder
 Dim xDay As String
 Dim XDate As Date
 Dim thatDay As String
 strMailboxName = "Deductions Backup"


    If Weekday(Now()) = vbMonday Then
        XDate = Date - 3
    Else
        XDate = Date - 1
    End If

    thatDay = WeekdayName(Weekday(XDate))

 Set myNameSpace = Application.GetNamespace("MAPI")
 Set myFolder = Session.Folders(strMailboxName)
 Set myFolder = myFolder.Folders("Inbox")
 Set myNewFolder = myFolder.Folders.Add(XDate & " " & thatDay)

'***Finds all emails in the inbox from yesterday and moves them to the created folder***

    Dim Inbox As Outlook.MAPIFolder
    Dim Items As Outlook.Items
    Dim Item As Object
    Dim Filter As String
    Dim i As Long

        Filter = "[ReceivedTime] >= '" & _
              CStr(XDate) & _
             " 12:00AM' AND [ReceivedTime] < '" & _
              CStr(XDate + 1) & " 12:00AM'"

        Debug.Print Filter

    Set myNameSpace = Application.GetNamespace("MAPI")
    Set myFolder = Session.Folders(strMailboxName)
    Set Inbox = myFolder.Folders("Inbox")
    Set Items = Inbox.Items.Restrict(Filter)
        Items.Sort "[ReceivedTime]"

    For i = Items.Count To 1 Step -1
        DoEvents
        If TypeOf Items(i) Is MailItem Then
            Debug.Print Items(i)
            Set Item = Items(i)
            Item.Move myNewFolder
        End If
    Next
End Sub

来源：https://stackoverflow.com/questions/50804937/find-emails-in-inbox-from-a-specific-date-and-move-them-to-a-new-folder