title: Select the first email
body: <p>I need to extract data from incoming emails in Outlook and save it as a row in Excel.</p>
  
  <p>I found a macro for Outlook to pull data from selected emails into Excel and another one to make the first macro trigger on receiving an email, BUT when it triggers, it still pulls the data from SELECTED email(s) and I need to get it from the first email in the inbox (the one that was just received).</p>
  
  <p>How can I select the first email?</p>
  
  <p>EDIT: Here's the first macro that extracts data from emails:</p>
  
  <pre><code>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 &lt;&gt; 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") &gt; 0 Then
      If InStr(olItem.Subject, "Re:") = 0 Then
  
      xlSheet.Range("A" &amp; rCount).Value = olItem.SenderName
      xlSheet.Range("B" &amp; 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:") &gt; 0 Then
              vItem = Split(vText(i), Chr(58))
              xlSheet.Range("C" &amp; rCount) = Trim(vItem(1))
          End If
  
          If InStr(1, vText(i), "Phone:") &gt; 0 Then
              vItem = Split(vText(i), Chr(58))
              xlSheet.Range("D" &amp; rCount) = Trim(vItem(1))
          End If
  
          If InStr(1, vText(i), "Email:") &gt; 0 Then
              vItem = Split(vText(i), Chr(58))
              xlSheet.Range("E" &amp; rCount) = Trim(vItem(1))
          End If
  
          If InStr(1, vText(i), "Address:") &gt; 0 Then
              vItem = Split(vText(i), Chr(58))
              xlSheet.Range("F" &amp; rCount) = Trim(vItem(1))
          End If
  
          If InStr(1, vText(i), "City:") &gt; 0 Then
              vItem = Split(vText(i), Chr(58))
              xlSheet.Range("G" &amp; rCount) = Trim(vItem(1))
          End If
  
          If InStr(1, vText(i), "Postal Code:") &gt; 0 Then
              vItem = Split(vText(i), Chr(58))
              xlSheet.Range("H" &amp; rCount) = Trim(vItem(1))
          End If
  
          If InStr(1, vText(i), "Preferred time to contact:") &gt; 0 Then
              vItem = Split(vText(i), Chr(58))
              xlSheet.Range("I" &amp; rCount) = Trim(vItem(1))
          End If
  
          If InStr(1, vText(i), "Message:") &gt; 0 Then
              vItem = Split(vText(i), Chr(58))
              xlSheet.Range("J" &amp; 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
  </code></pre>
  
  <p>And here's the part in ThisOutlookSession that makes it trigger on receiving an email:</p>
  
  <pre><code>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 &amp; " - " &amp; Err.Description
    Resume ProgramExit
  End Sub
  </code></pre>