Extract Email From Outlook Using Excel

[Hashiru]

Hi all,

I have the below code to extract emails from a particular contact in outlook (inbox) and from a particular date to now. The highlighted line of code is the problem. Here is the code I have so far:

Sub GetFromOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox) 
i = 1
For Each OutlookMail In Folder.Items
    If OutlookMail.ReceivedTime >= Range("FromDate").Value And ContactItem.LastName = "Williams" Then
        Range("eMail_subject").Offset(i, 0).Value = OutlookMail.Subject
        Range("eMail_date").Offset(i, 0).Value = OutlookMail.ReceivedTime
        Range("eMail_sender").Offset(i, 0).Value = OutlookMail.SenderName
        Range("eMail_text").Offset(i, 0).Value = OutlookMail.Body
        
        i = i + 1
    End If
Next OutlookMail
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
End Sub
<strike></strike>

Thanks in advance

 

[ZVI]

Hi,
Try this:

Sub GetFromOutlook()
'ZVI:2018-10-27 https://www.mrexcel.com/forum/general-excel-discussion-other-questions/1075339-extract-email-outlook-using-excel.html
 
  '--> User setting, change to suit
  Const SenderLastName = "Williams"
  Const StartDateRange = "FromDate"
  '<-- End of the setting
 
  ' Outlook's constants
  Const olFolderInbox As Long = 6, olMail As Long = 43
 
  ' Variables
  Dim OutlookApp As Object, OutlookMail As Object
  Dim i As Long
  Dim sFilter As String
 
  ' Get/create outlook object
  On Error Resume Next
  Set OutlookApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlookApp = CreateObject("Outlook.Application")
  End If
  On Error GoTo 0
 
  ' Restrict items
  sFilter = "[ReceivedTime] >= '" & Format(Range(StartDateRange).Value, "ddddd h:nn AMPM") & "'"
 
  ' Main
  For Each OutlookMail In OutlookApp.Session.GetDefaultFolder(olFolderInbox).Items.Restrict(sFilter) 
    If OutlookMail.Class = olMail Then
      If StrComp(GetLastName(OutlookMail), SenderLastName, 1) = 0 Then
        i = i + 1
        Range("eMail_subject").Offset(i, 0).Value = OutlookMail.Subject
        Range("eMail_date").Offset(i, 0).Value = OutlookMail.ReceivedTime
        Range("eMail_sender").Offset(i, 0).Value = OutlookMail.SenderName
        Range("eMail_text").Offset(i, 0).Value = OutlookMail.Body
      End If
    End If
  Next
 
  ' Release memory of the object variable
  Set OutlookApp = Nothing
 
End Sub
 
Function GetLastName(oMail As Object) As String
'ZVI:2018-10-27 returns sender's last name of oMail
  On Error Resume Next
  GetLastName = oMail.Sender.GetContact.LastName
End Function