选择第一封电子邮件

Question

我需要在 Outlook 中从收到的电子邮件中提取数据并将其保存为 Excel 中的一行。

我找到了一个宏，用于 Outlook 将数据从选定的电子邮件中提取到 Excel 中，另一个宏用于在接收电子邮件时触发第一个宏，但是当它触发时，它仍然从选定的电子邮件中提取数据，我需要从收件箱中的第一封电子邮件（刚刚收到的那封）中获取。

如何选择第一封电子邮件？

编辑：这是从电子邮件中提取数据的第一个宏：

Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String = "Z:\Leads\Leads Aggregator.xlsx" 'the path of the workbook

If Application.ActiveExplorer.Selection.Count = 0 Then
    MsgBox "No Items selected!", vbCritical, "Error"
    Exit Sub
End If
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
    Application.StatusBar = "Please wait while Excel source is opened ... "
    Set xlApp = CreateObject("Excel.Application")
    bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")

'Process each selected record
For Each olItem In Application.ActiveExplorer.Selection

    sText = olItem.Body
    vText = Split(sText, Chr(13))

'Find the next empty line of the worksheet
    rCount = xlSheet.UsedRange.Rows.Count
    rCount = rCount + 1

'Process emails only with specific subject
If InStr(olItem.Subject, "Message from") > 0 Then
    If InStr(olItem.Subject, "Re:") = 0 Then

    xlSheet.Range("A" & rCount).Value = olItem.SenderName
    xlSheet.Range("B" & rCount).Value = olItem.SentOn

    'Check each line of text in the message body
    For i = UBound(vText) To 0 Step -1

        If InStr(1, vText(i), "Name:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("C" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Phone:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("D" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Email:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("E" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Address:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("F" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "City:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("G" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Postal Code:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("H" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Preferred time to contact:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("I" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Message:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("J" & rCount) = Trim(vItem(1))
        End If

    Next i
    xlWB.Save

    End If
End If

Next olItem
xlWB.Close SaveChanges:=True
If bXStarted Then
    xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub

ThisOutlookSession 中的部分内容是在收到电子邮件时触发：

Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
  Dim olApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Set olApp = Outlook.Application
  Set objNS = olApp.GetNamespace("MAPI")
  ' default local Inbox
  Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)

  On Error GoTo ErrorHandler
  Dim Msg As Outlook.MailItem
  If TypeName(item) = "MailItem" Then
    Set Msg = item

  Call CopyToExcel

  End If
ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
End Sub

Answer 1

按未读排序，自动迭代直到发现最新的时间戳，存储消息正文，然后将内容传输到 Excel 单元格。

Sub TestEnvMacro()
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
'----------------------------------------------------
Set objMailbox = objNamespace.Folders("MAILHEADER") 'Update this with your mail header e.g.(Your.Name@Domain.Com)
'----------------------------------------------------
Set objFolder = objMailbox.Folders("Inbox")
Set colItems = objFolder.Items
Dim newestmsg: newestmsg = DateAdd("d", -1, Now)
Dim NewMsg
For Each objMessage In colItems.Restrict("[Unread] = True")
    If objMessage.CreationTime > newestmsg Then
        newestmsg = objMessage.CreationTime
        Set NewMsg = objMessage
    End If
Next

Dim ParsedStrings: ParsedStrings = Split(NewMsg.Body, vbCrLf)
'.... perform message parsing here
x = 1
For i = 1 To UBound(ParsedStrings)
    If Len(ParsedStrings(i)) > 1 Then
        Cells(x, 1).Value = ParsedStrings(i)
        x = x + 1
    End If
Next
If Err.Number <> 0 Then MsgBox Err.Description
End Sub

编辑

修订以符合 OP 的代码 - 试试这个，让我知道它是如何工作的。

Sub CopyToExcel()
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim olItem As Outlook.MailItem
    Dim vText As Variant
    Dim sText As String
    Dim vItem As Variant
    Dim i As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Const strPath As String = "Z:\Leads\Leads Aggregator.xlsx" 'the path of the workbook

    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Application.StatusBar = "Please wait while Excel source is opened ... "
        Set xlApp = CreateObject("Excel.Application")
        bXStarted = True
    End If
    On Error Goto 0
    'Open the workbook to input the data
    Set xlWB = xlApp.Workbooks.Open(strPath)
    Set xlSheet = xlWB.Sheets("Sheet1")

    Set objNS = olApp.GetNamespace("MAPI")
    Set colItems = objNS.GetDefaultFolder(olFolderInbox).Items

    'Process each selected record
    For Each olItem In colItems.Restrict("[Unread] = True")

        sText = olItem.Body
        vText = Split(sText, Chr(13))

        'Find the next empty line of the worksheet
        rCount = xlSheet.UsedRange.Rows.Count
        rCount = rCount + 1

        'Process emails only with specific subject
        If InStr(olItem.Subject, "Message from") > 0 Then
            If InStr(olItem.Subject, "Re:") = 0 Then

                xlSheet.Range("A" & rCount).Value = olItem.SenderName
                xlSheet.Range("B" & rCount).Value = olItem.SentOn

                'Check each line of text in the message body
                For i = UBound(vText) To 0 Step -1

                    If InStr(1, vText(i), "Name:") > 0 Then
                        vItem = Split(vText(i), Chr(58))
                        xlSheet.Range("C" & rCount) = Trim(vItem(1))
                    End If

                    If InStr(1, vText(i), "Phone:") > 0 Then
                        vItem = Split(vText(i), Chr(58))
                        xlSheet.Range("D" & rCount) = Trim(vItem(1))
                    End If

                    If InStr(1, vText(i), "Email:") > 0 Then
                        vItem = Split(vText(i), Chr(58))
                        xlSheet.Range("E" & rCount) = Trim(vItem(1))
                    End If

                    If InStr(1, vText(i), "Address:") > 0 Then
                        vItem = Split(vText(i), Chr(58))
                        xlSheet.Range("F" & rCount) = Trim(vItem(1))
                    End If

                    If InStr(1, vText(i), "City:") > 0 Then
                        vItem = Split(vText(i), Chr(58))
                        xlSheet.Range("G" & rCount) = Trim(vItem(1))
                    End If

                    If InStr(1, vText(i), "Postal Code:") > 0 Then
                        vItem = Split(vText(i), Chr(58))
                        xlSheet.Range("H" & rCount) = Trim(vItem(1))
                    End If

                    If InStr(1, vText(i), "Preferred time to contact:") > 0 Then
                        vItem = Split(vText(i), Chr(58))
                        xlSheet.Range("I" & rCount) = Trim(vItem(1))
                    End If

                    If InStr(1, vText(i), "Message:") > 0 Then
                        vItem = Split(vText(i), Chr(58))
                        xlSheet.Range("J" & rCount) = Trim(vItem(1))
                    End If

                Next i
                xlWB.Save

            End If
        End If

    Next olItem
    xlWB.Close SaveChanges:=True
    If bXStarted Then
        xlApp.Quit
    End If
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
    Set olItem = Nothing
End Sub