Question

我有一个宏，可以收到包含＆＃34; HAPPY＆＃34;，＆＃34; NEUTRAL＆＃34;的所有电子邮件。和＆＃34; SAD＆＃34;在主题中并将其复制到工作簿的新工作表。我想在用户还可以定义日期时添加功能，以便仅根据定义的日期显示心情。谁能帮助我？

此外，下面的代码阅读收件箱中的电子邮件。我需要它来阅读我的电子邮件中的所有文件夹（例如发件箱和子文件夹）。你能帮我解决这个问题吗？

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

Excel VBA：根据日期获取电子邮件主题

1 个答案: