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