Найти электронные письма в папке «Входящие» с определенной даты и переместить их в новую папку

Question

Я никогда раньше не создавал Outlook VBA, но у меня есть некоторый опыт работы с Excel VBA.Моя конечная цель:

1. Искать в почтовом ящике все электронные письма с определенной датой
2. Создать новую подпапку с именем определенной даты, которую я искал
3. Переместитьвсе электронные письма с этой даты из папки «Входящие» в только что созданную подпапку

Я искал какой-то VBA, который может это сделать, но пока не нашел ничего похожего на это.Ниже самый близкий, который я нашел.Этот код должен запрашивать у пользователя диапазон дат, который он хотел бы найти, а затем экспортировать информацию в Excel.Очевидно, я не хочу экспортировать что-либо, чтобы преуспеть, но я подумал, что код может быть хорошим местом для начала, чтобы хотя бы найти электронные письма из диапазона дат, который я ввел.Однако, когда я тестирую это, он ничего не находит в этом диапазоне, хотя у меня есть электронные письма в этом диапазоне.

Вот код на данный момент:

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

Например,, Я ищу диапазон «с 6/8/2018 по 6/9/2018 с 12:00 до 12:00», в котором у меня есть 3 электронных письма в этом диапазоне дат, однако он ничего не находит, поэтому я немного запуталсяпочему нет.

Если бы кто-нибудь мог помочь мне хотя бы начать поиск электронных писем с даты, которую вводит пользователь, это было бы здорово!Любая дополнительная помощь в создании папки и перемещении элементов была бы еще лучше, но я всегда могу найти эту часть отдельно.

Если есть совершенно другой код VBA, который был бы проще и эффективнее, тогда яготов избавиться от этого кода полностью.Просто это самое близкое, что я когда-либо получал.

Заранее благодарен.

Answer 1

Ниже приведен код, который я использовал для выполнения задачи.Я все еще работаю над тем, чтобы заставить его работать быстрее, но это выполняет работу (медленнее).

Он переместит электронные письма предыдущего рабочего дня из вторичной папки «Входящие» во вновь созданную подпапку с датой и днем.

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