根据日期获取电子邮件主题

Question

我有一个宏，它将获取主题中包含“HAPPY”、“NEUTRAL”和“SAD”的所有电子邮件，并将其复制到工作簿的新工作表中。我想添加功能以仅根据用户定义的日期显示心情。

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

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 中创建一个列表。

我已经修改了结构，以便它可以检测 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