Es que cree una macro que manda correos personalizados en VBA de excel pero al correrla me manda est
Publicado por Leonardo (2 intervenciones) el 08/02/2013 01:55:52
Es que cree una macro que manda correos personalizados en VBA de excel pero al correrla me manda este error. Alguien me podría decir como solucionarlo El error me lo manda en la parte de:
With OutMail
.Send
End With
A continuación pongo el código completo.
Sub EnviarArchivo()
Dim OutApp As Object
Dim OutMail As Object
Dim PageName(1), Archivo(5), Mensaje(7), Asunto(4), Correo As String
Dim X(1) As Integer
PageName(0) = "Hoja1"
PageName(1) = "Hoja2"
Archivo(0) = "C:\Leonardo.docx"
Archivo(1) = "C:\Enviador Macro.xlsx"
Archivo(2) = "C:\Enviador Código.docx"
Archivo(3) = "Leonardo.docx"
Archivo(4) = "Enviador Macro.xlsx"
Archivo(5) = "Enviador Código.docx"
Workbooks.Open (Archivo(1))
Workbooks("Enviador").Activate
Worksheets(PageName(0)).Activate
Mensaje(3) = Range("B5").Text
Mensaje(4) = Range("B6").Text
Mensaje(6) = Range("B7").Text
Asunto(0) = Range("B2").Text
Worksheets(PageName(1)).Activate
Range("A1").Activate
X(1) = ActiveCell.SpecialCells(xlCellTypeLastCell).Row
X(0) = 2
For X(0) = 2 To X(1)
Workbooks("Enviador.xlsm").Activate
Worksheets(PageName(1)).Activate
If Cells(X(0), 6).Text = "H" Then
Mensaje(0) = "Estimado "
Asunto(1) = "Estimado "
ElseIf Cells(X(0), 6).Text = "M" Then
Mensaje(0) = "Estimada "
Asunto(1) = "Estimada "
Else
Mensaje(0) = "Estimado(a) "
Asunto(1) = "Estimado(a) "
End If
Mensaje(1) = Cells(X(0), 1).Text
Asunto(2) = Cells(X(0), 1).Text
Mensaje(2) = Cells(X(0), 2).Text
Asunto(3) = Cells(X(0), 2).Text
Mensaje(5) = Cells(X(0), 5).Text
Correo = Cells(X(0), 4).Text
Mensaje(7) = Mensaje(0) & Mensaje(1) & Mensaje(2) & Mensaje(3) & Mensaje(4) & Mensaje(5) & Mensaje(6)
Asunto(4) = Asunto(0) & Asunto(1) & Asunto(2) & Asunto(3)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Workbooks(Archivo(4)).Activate
With OutMail
.To = Correo
.CC = ""
.BCC = ""
.Subject = Asunto(4)
.Body = Mensaje(7)
.Attachments.Add ActiveWorkbook.FullName
.Attachments.Add (Archivo(0))
.Attachments.Add (Archivo(2))
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
Next X(0)
Workbooks("Enviador.xlsm").Activate
Worksheets(PageName(0)).Activate
Range("A1").Activate
End Sub
With OutMail
.Send
End With
A continuación pongo el código completo.
Sub EnviarArchivo()
Dim OutApp As Object
Dim OutMail As Object
Dim PageName(1), Archivo(5), Mensaje(7), Asunto(4), Correo As String
Dim X(1) As Integer
PageName(0) = "Hoja1"
PageName(1) = "Hoja2"
Archivo(0) = "C:\Leonardo.docx"
Archivo(1) = "C:\Enviador Macro.xlsx"
Archivo(2) = "C:\Enviador Código.docx"
Archivo(3) = "Leonardo.docx"
Archivo(4) = "Enviador Macro.xlsx"
Archivo(5) = "Enviador Código.docx"
Workbooks.Open (Archivo(1))
Workbooks("Enviador").Activate
Worksheets(PageName(0)).Activate
Mensaje(3) = Range("B5").Text
Mensaje(4) = Range("B6").Text
Mensaje(6) = Range("B7").Text
Asunto(0) = Range("B2").Text
Worksheets(PageName(1)).Activate
Range("A1").Activate
X(1) = ActiveCell.SpecialCells(xlCellTypeLastCell).Row
X(0) = 2
For X(0) = 2 To X(1)
Workbooks("Enviador.xlsm").Activate
Worksheets(PageName(1)).Activate
If Cells(X(0), 6).Text = "H" Then
Mensaje(0) = "Estimado "
Asunto(1) = "Estimado "
ElseIf Cells(X(0), 6).Text = "M" Then
Mensaje(0) = "Estimada "
Asunto(1) = "Estimada "
Else
Mensaje(0) = "Estimado(a) "
Asunto(1) = "Estimado(a) "
End If
Mensaje(1) = Cells(X(0), 1).Text
Asunto(2) = Cells(X(0), 1).Text
Mensaje(2) = Cells(X(0), 2).Text
Asunto(3) = Cells(X(0), 2).Text
Mensaje(5) = Cells(X(0), 5).Text
Correo = Cells(X(0), 4).Text
Mensaje(7) = Mensaje(0) & Mensaje(1) & Mensaje(2) & Mensaje(3) & Mensaje(4) & Mensaje(5) & Mensaje(6)
Asunto(4) = Asunto(0) & Asunto(1) & Asunto(2) & Asunto(3)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Workbooks(Archivo(4)).Activate
With OutMail
.To = Correo
.CC = ""
.BCC = ""
.Subject = Asunto(4)
.Body = Mensaje(7)
.Attachments.Add ActiveWorkbook.FullName
.Attachments.Add (Archivo(0))
.Attachments.Add (Archivo(2))
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
Next X(0)
Workbooks("Enviador.xlsm").Activate
Worksheets(PageName(0)).Activate
Range("A1").Activate
End Sub
Valora esta pregunta


0