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 ответ:
Это позволит заглянуть в каждую папку в 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