Extract Emails from Outlook into Access Database

Public Sub GetEmails()
 
 
    DoCmd.SetWarnings False
 
 
    Dim rst              As ADODB.Recordset
    Dim OlApp            As Outlook.Application
    Dim Inbox            As Outlook.MAPIFolder
    Dim InboxItems       As Outlook.Items
    Dim Mailobject       As Object
 
    Set OlApp = CreateObject("Outlook.Application")
    Set Inbox = OlApp.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
    Set rst = New ADODB.Recordset
    Set InboxItems = Inbox.Items
 
        For Each Mailobject In InboxItems
             If (Mailobject.SenderName Like "*[email protected]*") Then
 
            With rst
                .ActiveConnection = CurrentProject.Connection
                .CursorType = adOpenKeyset
                .LockType = adLockOptimistic
                .Open "Select *from tbl_DigalertMails Order BY DateSent DESC"
                .AddNew
                !Subject = Mailobject.Subject
                !From = Mailobject.SenderName
                !To = Mailobject.To
                !Body = Mailobject.Body
                !DateSent = Mailobject.SentOn
                .Update
            End With
            rst.Close
            End If
 
        Next
 
 
 
    Set OlApp = Nothing
    Set Inbox = Nothing
    Set InboxItems = Nothing
    Set Mailobject = Nothing
    Set rst = Nothing
    DoCmd.SetWarnings True
 
 
End Sub