时间戳

首页 > 解决方案 > 在收件箱中查找特定日期的电子邮件并将它们移动到新文件夹

vba - 在收件箱中查找特定日期的电子邮件并将它们移动到新文件夹

问题描述

我的目标是：

  1. 在收件箱中搜索特定日期的电子邮件
  2. 创建一个名为特定日期的子文件夹
  3. 将电子邮件移动到子文件夹

我找到的最接近的 VBA 代码应该询问用户日期范围，然后将信息导出到 Excel。

我不想将任何内容导出到 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

例如，我搜索范围“2018 年 6 月 8 日到 2018 年 6 月 9 日，从上午 12:00 到上午 12:00”，我在该日期范围内有 3 封电子邮件，但没有找到任何内容。

标签： vbaoutlook

解决方案

下面是我最终用来完成任务的代码。我仍在努力让它运行得更快，但这可以完成工作（更慢）。

它将前一个工作日的电子邮件从辅助收件箱移动到新创建的带有日期和日期的子文件夹中。

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

推荐阅读