Get only the latest email in Outlook and copy to excel.

[MozQue]

Hello,

I'm new in Excel VBA and I'm trying to get only the Outlook's latest email body,sender, and subject and copy it to excel but my code is getting all the emails from today.

Sub GetDataFromOutlook()


Dim Outlook 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
x = Date




For Each OutlookMail In Folder.items


If InStr(OutlookMail.ReceivedTime, x) > 0 Then
Range("Email_Sender").Offset(i, 0).Value = OutlookMail.SenderName
Range("Email_Body").Offset(i, 0).Value = OutlookMail.Body
Range("Email_To").Offset(i, 0).Value = OutlookMail.To
Range("Email_CC").Offset(i, 0).Value = OutlookMail.CC
Range("Email_BCC").Offset(i, 0).Value = OutlookMail.BCC
i = i + 1

End If

Next OutlookMail







Set Folder = Nothing
Set OutlookNamespace = Nothing
Set outlookapp = Nothing




End Sub

 

[Domenic]

Try...

Sub GetDataFromOutlook()

    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olFolder As Outlook.Folder
    Dim olItems As Outlook.Items
    Dim olMailItem As Outlook.MailItem
    
    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.GetDefaultFolder(olFolderInbox)
    Set olItems = olFolder.Items
        
    If olItems.Count > 0 Then
        olItems.Sort Property:="ReceivedTime", Descending:=True
        Set olMailItem = olItems.GetFirst()
        Range("Email_Sender").Offset(1, 0).Value = olMailItem.SenderName
        Range("Email_Body").Offset(1, 0).Value = olMailItem.Body
        Range("Email_To").Offset(1, 0).Value = olMailItem.To
        Range("Email_CC").Offset(1, 0).Value = olMailItem.CC
        Range("Email_BCC").Offset(1, 0).Value = olMailItem.BCC
    Else
        MsgBox "No items found!", vbExclamation
    End If
    
    Set olApp = Nothing
    Set olNS = Nothing
    Set olFolder = Nothing
    Set olItems = Nothing
    Set olMailItem = Nothing
    
End Sub

Hope this helps!