Access - Insertar archivos

Private Sub btnGuardarAdjunto_Click()

    Dim objOutlook As Object

    Dim objNamespace As Object

    Dim objFolder As Object

    Dim objMail As Object

    Dim objAttachment As Object

    Dim strAttachmentPath As String

    ' Crea una instancia de Outlook

    Set objOutlook = CreateObject("Outlook.Application")

    Set objNamespace = objOutlook.GetNamespace("MAPI")

    ' Abre la carpeta de correos

    Set objFolder = objNamespace.GetDefaultFolder(6) ' Valor 6 para la carpeta "Bandeja de entrada"

    ' Abre el último correo seleccionado

    Set objMail = objFolder.Items.GetLast

    ' Verifica si hay archivos adjuntos

    If objMail.Attachments.Count > 0 Then

        ' Guarda el primer archivo adjunto en la carpeta temporal de Access

        Set objAttachment = objMail.Attachments.Item(1) ' Cambiar el índice si se desea guardar otro adjunto

        strAttachmentPath = Environ$("temp") & "\" & objAttachment.Filename ' Ruta de la carpeta temporal de Access

        objAttachment.SaveAsFile strAttachmentPath

        ' Almacena la ruta del archivo en un campo de texto en Access

        Me.txtRutaArchivoAdjunto.Value = strAttachmentPath

        ' Abre el archivo adjunto directamente desde Access

        Application.FollowHyperlink strAttachmentPath

    Else

        ' No se encontraron archivos adjuntos

        MsgBox "No se encontraron archivos adjuntos en el correo seleccionado.", vbInformation, "Adjunto no encontrado"

    End If

    ' Limpia los objetos

    Set objAttachment = Nothing

    Set objMail = Nothing

    Set objFolder = Nothing

    Set objNamespace = Nothing

    Set objOutlook = Nothing

End Sub