Vincular correos Access Outlook

Dim OL As Outlook.Application
Dim Ns As Outlook.NameSpace
Dim oMail As Outlook.MailItem
Dim oMail2 As Outlook.MailItem
Dim rs As DAO.Recordset
Dim f As Outlook.Folder
Dim MensajesEnviados As Long
    
    Set OL = CreateObject("Outlook.Application")
    Set Ns = OL.GetNamespace("MAPI")
    ' referenciamos la carpeta enviados
    Set f = Ns.GetDefaultFolder(olFolderSentMail)
    
    Set oMail = OL.CreateItem(olMailItem)
    oMail.Subject = "Asunto del mensaje de correo"
    oMail.To = "destimatario@dominio.com"
    ' tomamos nota del nº de mensajes enviados hasta el momento
    MensajesEnviados = f.Items.Count
    ' enviamos el mensaje
    oMail.send
    ' bucle para esperar que se actualice la carpeta enviados
    ' cuando notemos que el nº de mensajes cambie, salimos del bucle
    Do While MensajesEnviados = f.Items.Count
        DoEvents
    Loop
    ' referenciamos el último mail de la carpeta enviados
    Set oMail2 = f.Items(f.Items.Count)
    ' y ahora guardamos el EntryID de ese mensaje    
    Set rs = CurrentDb.OpenRecordset("TuTabla")
    rs.AddNew
    rs("Asunto") = oMail2.Subject
    rs("EntryID") = oMail2.EntryID
    rs.Update

    ' ... ...