Excel - Envio Masivo de correos con adjunto

Saludos a la comunidad. Tengo este archivo que quiero que trabaje enviando varios correos a distintos destinatarios con archivos adjuntos. La Macro recorre la Hoja1 y selecciona todos los archivos a enviar, correos de destinatarios y el asunto. Hasta ahora no logro el funcionamiento de la macro que esta vinculado a Outlook.

Además también me gustaría que la macro trabaje no solo con Outlook, también que envíe correos desde Gmail y Yahoo.
Espero su ayuda. A continuación envío la macro y los Adjuntos PDF a enviar por correo.

• Macro-Envia-correos.zip(1,0 MB)

Echa un vistazo a esta web:

https://www.rondebruin.nl/

Cada vez que ejecuto la macro se queda pegado y no hay forma de salir de Excel tengo que reiniciar el Laptop. Si desactivo el codigo
olMail: Close
olApp: Close
Me marca error en olMail.Attachments.Add (adjunto). Si le coloco On Error Resume Next se vuelve a quedar pegado el proceso.



Sub ENVIAR_CORREOS()
'Declaramos variables
Dim sFSO As Object, Directorio As String
Dim Dir_Archivo As Variant

'Abrimos ventana de dialogo para seleccionar carpeta
Set Dir_Archivo = Application.FileDialog(msoFileDialogFolderPicker)
Dir_Archivo.Show

'Sino seleccionamos nada salimos del proceso
If Dir_Archivo.SelectedItems.Count = 0 Then
Exit Sub
End If

'Capturamos el directorio
Directorio = Dir_Archivo.SelectedItems(1)

'Creamos objeto y ejecutamos funcion carpeta
Set sFSO = CreateObject("Scripting.FileSystemObject")
CARPETA sFSO.GetFolder(Directorio)
End Sub

Function CARPETA(ByVal nCarpeta)

'Declaramos variables
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim fin As Long, i As Long, File As Variant
Dim adjunto As String, nFile As String
Dim olMailItem As Variant, Celda As Variant

'Iniciamos funcion
With Sheets("Hoja1")
fin = Application.CountA(.Range("A:A"))

'Recorremos hoja y celda para comprobar si hace Referencia varios Archivos
For i = 2 To fin
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(olMailItem)
For Each Celda In Split(.Cells(i, 1), "|")
For Each File In nCarpeta.Files
adjunto = File
nFile = Left(File.Name, InStr(File.Name, ".") - 1)
If Celda = nFile Then

'Destinatario
olMail.To = .Cells(i, 2)

'Copia a
olMail.CC = .Cells(i, 3)

'Con Copia Oculta
olMail.BCC = .Cells(i, 4)

'Asunto
olMail.Subject = .Cells(i, 5)

'Cuerpo de correo
olMail.HTMLBody = "Junto con saludarlos;Enviamos archivos solicitados. Atentamente."

'Adjuntamos archivos y dejamos correo en bandeja de salida
olMail.Attachments.Add (adjunto)

'Para enviar debes utilizar Send en vez de Display
'olMail.Send
olMail.Display
End If

Next File
Next Celda
olMail: Close
olApp: Close
Next i
End With
Set olMail = Nothing
Set olApp = Nothing
End Function

• Envio-Masivo-con-Adjunto.zip(17,0 KB)
• Carpeta-Adjuntos.zip(1.022,2 KB)

Estás creando un objeto olApp dentro del bucle y lo estás cerrando fuera, por lo que no liberas la memoria.

Debes crear el objeto olApp fuera, y cerrarlo al final.

Hola Martha, se sigue quedando pegado.

Sub ENVIAR_CORREOS()
'Declaramos variables
Dim sFSO As Object, Directorio As String
Dim Dir_Archivo As Variant

'Abrimos ventana de dialogo para seleccionar carpeta
Set Dir_Archivo = Application.FileDialog(msoFileDialogFolderPicker)
Dir_Archivo.Show

'Sino seleccionamos nada salimos del proceso
If Dir_Archivo.SelectedItems.Count = 0 Then
Exit Sub
End If

'Capturamos el directorio
Directorio = Dir_Archivo.SelectedItems(1)

'Creamos objeto y ejecutamos funcion carpeta
Set sFSO = CreateObject("Scripting.FileSystemObject")
CARPETA sFSO.GetFolder(Directorio)
End Sub

Function CARPETA(ByVal nCarpeta)

'Declaramos variables
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim fin As Long, i As Long, File As Variant
Dim adjunto As String, nFile As String
Dim olMailItem As Variant, Celda As Variant

'Iniciamos funcion
With Sheets("Hoja1")
fin = Application.CountA(.Range("A:A"))
Set olApp = CreateObject("Outlook.Application")
'Recorremos hoja y celda para comprobar si hace Referencia varios Archivos
For i = 2 To fin

Set olMail = olApp.CreateItem(olMailItem)
On Error Resume Next
For Each Celda In Split(.Cells(i, 1), "|")
For Each File In nCarpeta.Files
adjunto = File
nFile = Left(File.Name, InStr(File.Name, ".") - 1)
If Celda = nFile Then

'Destinatario
olMail.To = .Cells(i, 2)

'Copia a
olMail.CC = .Cells(i, 3)

'Con Copia Oculta
olMail.BCC = .Cells(i, 4)

'Asunto
olMail.Subject = .Cells(i, 5)

'Cuerpo de correo
olMail.HTMLBody = "Junto con saludarlos;Enviamos archivos solicitados. Atentamente."

'Adjuntamos archivos y dejamos correo en bandeja de salida
olMail.Attachments.Add (adjunto)

'Para enviar debes utilizar Send en vez de Display
'olMail.Send
olMail.Display
End If

Next File
Next Celda
olMail: Close
olApp: Close
Next i
End With
Set olMail = Nothing
Set olApp = Nothing
End Function

Como puedo modificar esta macro para enviar s archivos adjuntos?

Hola a todos:
Usando Office y Adobe puedes enviar adjuntos automáticamente sin necesidad de macros. También hay complementos para Word.
https://www.youtube.com/watch?v=Yrf24IMdD2E&list=PLF1OL9sNXkSxGL52T9306FIUtzXOnhDwB&index=11&t=24s&ab_channel=WordExperto