Get email subject based on dates

Question

I have a macro that will get all emails that contains "HAPPY", "NEUTRAL" and "SAD" in the subject and copy it to a new sheet of the workbook. I want to add functionality to only display mood based on the date defined by a user.

Also, code below read emails in the inbox. I need it to read all the folders in my mailbox (eg Outbox and subfolders).

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

This will look into every folders in Outlook and gather the information in mInfo to create a list in sheet Report .

I've modified the structure so that it'll detect if Outlook is already open, add a column with the detected mood and improve performances! ;)

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