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


У меня есть макрос, который будет получать все электронные письма, содержащие "счастливый", "нейтральный" и "грустный" в теме и копировать его на новый лист рабочей книги. Я хочу добавить функциональность, когда пользователь может также определить дату, чтобы только отображать настроение на основе определенной даты. Кто-нибудь может мне помочь?

Кроме того, код ниже читать электронные письма в папке Входящие. Мне нужно, чтобы он читал все папки в моей электронной почте (например, исходящие и подпапки). Не могли бы вы также помочь мне с этим?

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
1 3

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