选择第一封电子邮件

Question

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

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

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

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

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