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内のすべてのフォルダに見て、シートReportでリストを作成するmInfoに情報を収集します。

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