Excel VBA：根据date获取电子邮件主题

我有一个macros将获得主题中包含“HAPPY”，“NEUTRAL”和“SAD”的所有电子邮件，并将其复制到工作簿的新工作表中。 我想添加一个function，当用户也可以定义一个date，只显示基于定义的date心情。 任何人都可以帮我吗？

此外，下面的代码阅读收件箱中的电子邮件。 我需要它来读取我的电子邮件中的所有文件夹（例如发件箱和子文件夹）。 你能帮我一下吗？

Sub GetMood() Dim outlookApp Dim olNs As Outlook.Namespace Dim Fldr As Outlook.MAPIFolder Dim olMail As Variant Dim myTasks Dim sir() As String Dim ws As Worksheet Dim iRow As Variant Dim d As Date x = 2 d = ThisWorkbook.Sheets("Main").Cells(11, 7).Value Set outlookApp = CreateObject("Outlook.Application") Set olNs = outlookApp.GetNamespace("MAPI") Set Fldr = olNs.GetDefaultFolder(olFolderInbox) Set myTasks = Fldr.Items For Each olMail In myTasks If (InStr(1, olMail.Subject, "HAPPY") > 0) Then ThisWorkbook.Sheets("Report").Cells(1, 1) = "Sender" ThisWorkbook.Sheets("Report").Cells(1, 2) = "Mood" ThisWorkbook.Sheets("Report").Cells(1, 3) = "Date" ThisWorkbook.Sheets("Report").Cells(x, 1) = olMail.SenderName ThisWorkbook.Sheets("Report").Cells(x, 2) = olMail.Subject ThisWorkbook.Sheets("Report").Cells(x, 3) = olMail.ReceivedTime x = x + 1 ElseIf (InStr(1, olMail.Subject, "NEUTRAL") > 0) Then ThisWorkbook.Sheets("Report").Cells(x, 1) = olMail.SenderName ThisWorkbook.Sheets("Report").Cells(x, 2) = olMail.Subject ThisWorkbook.Sheets("Report").Cells(x, 3) = olMail.ReceivedTime x = x + 1 ElseIf (InStr(1, olMail.Subject, "SAD") > 0) Then ThisWorkbook.Sheets("Report").Cells(x, 1) = olMail.SenderName ThisWorkbook.Sheets("Report").Cells(x, 2) = olMail.Subject ThisWorkbook.Sheets("Report").Cells(x, 3) = olMail.ReceivedTime x = x + 1 'MsgBox "Report Generated", vbOKOnly 'Else 'olMail.Display Exit For End If Next End Sub Private Sub Workbook_Open() Worksheets("StartSheet").Activate End Sub 

Answer 1

这将查看Outlook中的每个文件夹并收集mInfo的信息以在工作表Report创build一个列表。

我已经修改了结构，以便它能够检测Outlook是否已经打开，添加一个具有检测到的心情的列，并提高性能！ ;）

 Sub GetMood() Dim wS As Excel.Worksheet Dim outlookApp As Outlook.Application Dim olNs As Outlook.Namespace Dim Fldr As Outlook.MAPIFolder Dim olMail As Outlook.MailItem 'Dim sir() As String 'Dim iRow As Variant 'Dim d As Date Dim RgPaste As Excel.Range Dim mSubj As String Dim mInfo() As Variant Dim nbInfos As Integer ReDim mInfo(1 To 1, 1 To 3) nbInfos = UBound(mInfo, 2) 'd = ThisWorkbook.Sheets("Main").Cells(11, 7).Value Set wS = ThisWorkbook.Sheets("Report") With wS .Cells(1, 1) = "Sender" .Cells(1, 2) = "Mood" .Cells(1, 3) = "Date" Set RgPaste = .Cells(2, 1) End With 'wS Set outlookApp = GetObject(, "Outlook.Application") If outlookApp Is Nothing Then Set outlookApp = CreateObject("Outlook.Application") Set olNs = outlookApp.GetNamespace("MAPI") For Each Fldr In olNs.Folders For Each olMail In Fldr.Items With olMail mSubj = .Subject mInfo(1, 1) = .SenderName mInfo(1, 2) = mSubj mInfo(1, 3) = .ReceivedTime '.Display End With 'olMail With RgPaste If (InStr(1, mSubj, "HAPPY") > 0) Then .Resize(1, nbInfos).Value = mInfo .Offset(0, nbInfos) = "HAPPY" Set RgPaste = .Offset(1, 0) ElseIf (InStr(1, mSubj, "NEUTRAL") > 0) Then .Resize(1, nbInfos).Value = mInfo .Offset(0, nbInfos) = "NEUTRAL" Set RgPaste = .Offset(1, 0) ElseIf (InStr(1, mSubj, "SAD") > 0) Then .Resize(1, nbInfos).Value = mInfo .Offset(0, nbInfos) = "SAD" Set RgPaste = .Offset(1, 0) End If End With 'RgPaste Next olMail Next Fldr 'MsgBox "Report Generated", vbOKOnly End Sub