Aşağıdaki kod işinize yarar. Çalışması için bir kural oluşturmanız gerekiyor. Bunun nasıl yapılacağını burada açıklamıştık.  Bu kuralı oluşturduğunuzda outlook gelen her mailin bilgisayarınızda belirlediğiniz dosyaya kaydedecektir.

Option Explicit
Private Const xlUp As Long = -4162

Sub Mail2Excel(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 strPath As String
‘NEREYE KAYDEDİLECEKSE BURAYA ONU GİRECEKSİN
strPath = “E:\Mailler\Rapor.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

Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets(1) ‘ Sayfa adı varsa buraya gireceksin

rCount = xlSheet.Range(“B” & xlSheet.Rows.Count).End(xlUp).Row ‘ Dolu son satırı bul
rCount = rCount + 1

sText = olItem.Body
xlSheet.Range(“a” & rCount) = olItem.ReceivedTime
xlSheet.Range(“b” & rCount) = olItem.SenderName & “-” & olItem.SenderEmailAddress
xlSheet.Range(“c” & rCount) = olItem.To
xlSheet.Range(“d” & rCount) = olItem.CC
xlSheet.Range(“e” & rCount) = olItem.Subject
xlSheet.Range(“f” & rCount) = olItem.Body
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing

End Sub