Enviar correo adjuntando todos los archivos de una carpeta

Esta sería la macro para enviar todos los archivos de una carpeta.

Sigue las Instrucciones para ejecutar la macro
1. Abre tu archivo de excel
2. Para abrir Vba-macros y poder pegar la macro, Presiona Alt + F11
3. En el menú elige Insertar / Módulo
4. En el panel del lado derecho copia la macro
5. Para ejecutarla presiona F5

Sub enviararchivos()
'Por.DAM
ruta = ThisWorkbook.Path
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Selecciona una carpeta"
    .AllowMultiSelect = False
    .InitialFileName = ruta
    If .Show <> -1 Then Exit Sub
    cp = .SelectedItems(1)
End With
ChDir cp
arch = Dir("*.*")
    Set dam2 = CreateObject("outlook.application").createitem(0)
    dam2.To = "[email protected]" 'Destinatarios
    dam2.Subject = "Enviar archivos de una carpeta" '"Asunto"
    dam2.body = "descripción" '"Cuerpo del mensaje"
    Do While arch <> ""
        dam2.Attachments.Add cp & "\" & arch
        arch = Dir()
    Loop
    dam2.send 'El correo se envía en automático
    dam2.display 'El correo se muestra
End Sub

Cambia en la macro "[email protected]", por el correo del destinatario. Cambia "Enviar archivos de una carpeta", por el texto que quieras que se envíe como asunto. Y cambia "descripción" por la información que quieres que vaya en el cuerpo del mensaje.

Sub Envia_Correo()
    Dim Destinatario As String
    Destinatario = "[email protected]"
    strFileName = ActiveWorkbook.Name & ".xls"
            Dim objOL As Outlook.Application
            Dim objMail As MailItem
            Set objOL = New Outlook.Application
            Set objMail = objOL.CreateItem(olMailItem)
            With objMail
                .To = Destinatario
                .Subject = " Actualizado: " & ActiveWorkbook.Name
                .Body = "Fecha: " & Date & "  -   Hora :" & Time
                .Attachments.Add ActiveWorkbook.FullName
'                .Display
                .Send
            End With
            Set objMail = Nothing
            Set objOL = Nothing
 End Sub

Es vieja la pregunta pero me gusta este código mas simple

Comparto tu código adicionando en la descripción (body) la selección de un rango (tablas) sin perder formato. Donde se puede adicionar firma o imágenes que se encuentre dentro de la hoja de calculo.

Sub enviararchivos()
'Por.DAM
ruta = ThisWorkbook.Path
Dim xInspect As Object
Dim pageEditor As Object
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Selecciona una carpeta"
    .AllowMultiSelect = False
    .InitialFileName = ruta
    If .Show <> -1 Then Exit Sub
    cp = .SelectedItems(1)
End With
ChDir cp
arch = Dir("*.*")
    Set dam2 = CreateObject("outlook.application").CreateItem(0)
    dam2.To = "[email protected]" 'Destinatarios
    dam2.Subject = "Enviar archivos de una carpeta" '"Asunto"
    dam2.Body = "_DESCRIPCION" & vbCrLf & "_DESCRIPCION"
    dam2.display
    Set xInspect = dam2.GetInspector
    Set pageEditor = xInspect.WordEditor
     Sheets("hoja1").Range("A1:I15").Copy
    pageEditor.Application.Selection.Start = Len(dam2.Body)
    pageEditor.Application.Selection.End = pageEditor.Application.Selection.Start
    pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)
    Do While arch <> ""
        dam2.Attachments.Add cp & "\" & arch
        arch = Dir()
    Loop
    dam2.Send 'El correo se envía en automático
    Set pageEditor = Nothing
    Set xInspect = Nothing
    'dam2.display 'El correo se muestra
End Sub