Excel VBA: Получить тему по электронной почте на основе дат

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