Question

我以前从未制作任何Outlook VBA，但我对Excel VBA有一些经验。我的最终目标是：

在收件箱中搜索特定日期的所有电子邮件
创建一个名为我搜索的特定日期的新子文件夹
将该日期的所有电子邮件从收件箱移至刚创建的子文件夹

我一直在寻找能够做到这一点的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

例如，我搜索范围“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

从特定日期在收件箱中查找电子邮件并将其移至新文件夹

1 个答案: