Macro no funciona para enviar correo desde excel
Tengo problema con la siguiente macro:
Sub Correo()
For i = 2 To Range("P" & Rows.Count).End(xlUp).Row
If UCase(Cells(i, "O")) = "ENVIAR" Then
Set dam = CreateObject("outlook.application").createitem(0)
dam.To = Cells(i, "P") 'Destinatario
dam.Subject = Cells(i, "A") '"Asunto"
dam.Body = "Hola!! Dentro de 2 días se cambia las Dosis de Fertilización del Productor Mencionado en el Asunto, ¡¡AVÍSALE!!"
dam.Send 'Enviar correo
'dam.Display 'Muestra correo
End If
Next
MsgBox "Correos enviados", vbInformation, "SALUDOS"
End Sub
El objetivo de esta macro es que cuando abra el archivo de Excel 2013 se ejecute esta macro automáticamente y me envíe por correo los recordatorios de todas las celdas que contengan la palabra "ENVIAR". El problema radica en que no funciona así como está, pues genera "error en el método subject de objeto Mailitem" y en Outlook no se cargan el destinatario ni el asunto y no se envía. Verifiqué la macro en modo depurar y cuando colocas el cursor sobre las referencias destinatario y asunto aparecen los datos correctos flotantes pero no los carga en Outlook, así que borré "Cells (i, "X") y escribí directamente la dirección del destinatario "[email protected]" y el asunto y solo así funciona bien, se envía y no genera error. Está activado Microsoft Outlook 15.0 Object Library, ¿hay alguna solución?
1 respuesta
H o l a:
¿Tienes el destinatario en la columna P?
¿Cómo se llama la hoja donde tienes los datos?
Prueba con la siguiente macro, cambia "Hoja1" por el nombre de la hoja en donde tienes los datos.
Sub Correo()
'Por.Dante Amor
Set h = Sheets("Hoja1")
For i = 2 To h.Range("P" & Rows.Count).End(xlUp).Row
If UCase(h.Cells(i, "O")) = "ENVIAR" Then
Set dam = CreateObject("outlook.application").createitem(0)
dam.To = h.Cells(i, "P") 'Destinatario
dam.Subject = h.Cells(i, "A") '"Asunto"
dam.Body = "Hola!! Dentro de 2 días se cambia las Dosis de Fertilización del Productor Mencionado en el Asunto, ¡¡AVÍSALE!!"
dam.Send 'Enviar correo
'dam.Display 'Muestra correo
End If
Next
MsgBox "Correos enviados", vbInformation, "SALUDOS"
End SubSi todavía tienes problemas, podrías enviarme tu archivo con la macro para revisarlo.
Mi correo [email protected]
En el asunto del correo escribe tu nombre de usuario “” y el título de esta pregunta.
Avísame en esta pregunta cuando me lo hayas enviado.
':)
S a l u d o s . D a n t e A m o r
':) Si es lo que necesitas. R ecuerda valorar la respuesta. G r a c i a s.
Envié a tu correo el archivo
H o l a:
Primero, para que la macro se ejecute cuando abres el archivo, tienes que poner esta macro en los eventos de Thisworkbook:
Private Sub Workbook_Open() 'Por.Dante Amor Call Correo End Sub
Te anexo la macro actualizada:
Sub Correo()
'Por.Dante Amor
Set h = Sheets("DATOS")
For i = 6 To Range("S" & Rows.Count).End(xlUp).Row
If UCase(h.Cells(i, "S")) = "ENVIAR" Then
If h.Cells(i, "T") <> "" Then
Set dam = CreateObject("outlook.application").createitem(0)
dam.To = h.Cells(i, "T") 'Destinatario
dam.Bcc = h.Range("T1") 'Copia oculta
dam.Subject = h.Cells(i, "C") '"Asunto"
dam.Body = "Hola!! Dentro de 2 días se cambia las Dosis de " & _
"Fertilización del Productor Mencionado en el Asunto, ¡¡AVÍSALE!!"
dam.Display 'Muestra correo
dam.Send 'Enviar correo
End If
End If
Next
MsgBox "Correos enviados", vbInformation, "SALUDOS"
End Sub':) 'S aludos. D a n t e A m o r . R ecuerda valorar la respuesta. G racias ':)
Esta es la macro final:
Sub Mail_with_outlook1()
'Act.Por.Dante Amor
Dim OutApp As Object
Dim OutMail As Object
Dim strto As String, strcc As String, strbcc As String
Dim strsub As String, strbody As String
'
For i = 6 To Range("S" & Rows.Count).End(xlUp).Row
If UCase(Cells(i, "S")) = "ENVIAR" Then
If Cells(i, "T") <> "" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.createitem(0)
strto = Cells(i, "T").Value
'strcc = ""
strbcc = Range("T1")
strsub = Cells(i, "C").Value
strbody = "Hola!! Dentro de 2 días se cambia las Dosis de " & _
"Fertilización del Productor Mencionado en el Asunto, ¡¡AVÍSALE!!"
With OutMail
.To = strto
'.CC = strcc
.Bcc = strbcc
.Subject = strsub
.Body = strbody
.Display ' or use .Send .display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End If
End If
Next
End Sub':) 'S aludos. D a n t e A m o r . R ecuerda valorar la respuesta. G racias ':)
¡Gracias! de verdad, creo que te di mucha lata pero en serio te lo agradezco, al final todo resultó muy bien, Saludos y que pases muy buenas noches!!
