Enviar rango de celdas de excel a varios destinatarios
Tengo la siguiente macro para enviar un rango determinado pero se me presentan un error:
Se ha producido el error '429" en tiempo de ejecución:
El componente ActiveX no puede crear el objeto.
Ya verifique que la librería de outllook este habilitada.
Si tienen una formas mas fácil, estoy abierto a opciones.
Sub EnviarEmail()
'
' Declaramos variables
'
Dim OutlookApp As Outlook.Application
Dim MItem As Outlook.MailItem
Dim cell As Range
Dim Asunto As String
Dim Correo As String
Dim Destinatario As String
Dim Saldo As String
Dim Msg As String
'
Set OutlookApp = New Outlook.Application
'
'Recorremos la columna EMAIL
'
For Each cell In Range("B1:B2")
'
'Asignamos valor a las variables
'
Asunto = "Saldo vencido"
Destinatario = cell.Offset(0, -1).Value
Correo = cell.Value
Saldo = Format(cell.Offset(0, 1).Value, "$#,##0")
FechaVencimiento = Format(cell.Offset(0, 2).Value, "dd/mmm/yyyy")
'
'Cuerpo del mensaje
'
Msg = "Apreciable " & Destinatario & vbNewLine & vbNewLine
Msg = Msg & "Queremos informarle que su fecha de pago venció el día "
Msg = Msg & FechaVencimiento & "." & vbNewLine & vbNewLine
Msg = Msg & "El saldo que debe liquidar es "
Msg = Msg & Saldo & vbNewLine & vbNewLine
Msg = Msg & "Atentamente:" & vbNewLine
Msg = Msg & "Tarjetas de crédito."
'
Set MItem = OutlookApp.CreateItem(olMailItem)
With MItem
.To = Correo
.Subject = Asunto
.Body = Msg
.Send
'
End With
'
Next
'
End Sub2 Respuestas
Yo uso el envió de un rango en excel y lo convierto en un archivo pdf con esta macro:
Sub EnvioEmailHojaActivaPDF()
Dim olApp As Object
Dim olMail As Object
Dim RutaTemporal As String
Dim NombreTemporal As String
Dim RutaCompleta As String
mensaje = MsgBox("Desea enviar por mail el informe?", vbYesNo, "Infromes Nova")
If mensaje = vbNo Then
Exit Sub
Else
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
RutaTemporal = Environ$("temp") & "\"
NombreTemporal = ActiveSheet.Name & ".pdf"
RutaCompleta = RutaTemporal & NombreTemporal
On Error GoTo Err
On Error Resume Next
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=RutaCompleta, _
quality:=xlQualityStandard, _
includedocproperties:=True, _
ignoreprintareas:=False, _
openafterpublish:=False
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(0)
On Error Resume Next
With olMail
.To = "[email protected]"
.CC = "[email protected];[email protected]"
.Subject = "Resumen de Operaciones 2018"
.Body = "Colocacion de cartera por el ejercicio 2018"
.Attachments.Add RutaCompleta
ActiveSheet.Range("A3:K97").Select
ActiveWorkbook.EnvelopeVisible = True
.Send
End With
On Error GoTo 0
On Error Resume Next
Kill RutaCompleta
Set olApp = Nothing
Set olMail = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
ActiveWorkbook.EnvelopeVisible = False
Exit Sub
Err:
MsgBox Err.Description, vbCritical + vbOKOnly, Err.Number
End If
End Sub
Gracias por tu pronta respuesta, ya la ejecute sin embargo nunca manda ningún mail me podrías ayudar con más detalles.
Podría enviarme algo de su archivo para tratar de detectar el problema y buscar una solución