Option Explicit
 
Private WithEvents olInboxItems As Items
Private WithEvents olSentItems As Items
 
 
Private Sub Application_Startup()
  Dim objNS As NameSpace
  Set objNS = Application.Session
  Set olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
  Set olSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items
  Set objNS = Nothing
End Sub
 
Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
 CopyToExcel Item
End Sub

Private Sub olSentItems_ItemAdd(ByVal Item As Object)
 CopyToExcel Item
End Sub


 Sub CopyToExcel(olItem As Outlook.MailItem)
 Dim xlApp As Object
 Dim xlWB As Object
 Dim xlSheet As Object
 Dim sText As String
 Dim rCount As Long
 Dim bXStarted As Boolean
 Dim enviro As String
 Dim strPath As String
 Dim Reg1 As Object
 Dim M1 As Object
 Dim M As Object
               
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
  strPath = enviro & "\Documents\Email.xlsx"
     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)
     
'The name of the workbook sheet
     Set xlSheet = xlWB.Sheets("Sheet1")
 
    'Find the next empty line of the worksheet
     rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
     rCount = rCount + 1
      
 With olItem
  xlSheet.Range("b" & rCount) = .Subject
  xlSheet.Range("c" & rCount) = .SenderName
  xlSheet.Range("d" & rCount) = .To
  xlSheet.Range("e" & rCount) = .ReceivedTime
 End With


 
     xlWB.Close 1
     If bXStarted Then
         xlApp.Quit
     End If
     Set M = Nothing
     Set M1 = Nothing
     Set Reg1 = Nothing
     Set xlApp = Nothing
     Set xlWB = Nothing
     Set xlSheet = Nothing
 End Sub