Código que no funciona para enviar mail VBA
Quisiera saber por qué al momento de correr el código siguiente, luego de demorarse bastante tiempo, me arroja error de tipo: supera capacidad.
Mi idea es que el código vaya revisando en una hoja llamada "tableau de donné" distintas fechas que están en la columna DE y en las filas a partir de la 2. Esta fecha cada vez sera comparada a la fecha ingresada en la fila 1 columna G de la hoja "Mail" y si corresponde a la misma fecha, quiero que agregue el numero de "OF" (buscado en la misma fila donde encontró la coincidencia y en la columna B)dentro del mail que estoy escribiendo.
El código que escribí es el siguiente:
Sub EnvoyerMail()
Dim OutlookApp As Outlook.Application
Dim MItem As Outlook.MailItem
Dim Sujet As String
Dim Dest As String
Dim Message As String
Dim ligne As Long
Dim cont As Date
Dim fecha As Date
Dim OF As String
Set OutlookApp = New Outlook.Application
Sujet = "Liste OF à imprimer"
Dest = Sheets("Mail").Cells(2, 7) 'mail destinataire
Message = "Caroline, j'ai besoin d'imprimmer les étiquettes correspondant aux OF suivants:"
ligne = 2
cont = Sheets("Tableau de donné").Cells(ligne, 4)
fecha = Sheets("Mail").Cells(1, 7)
While cont <> Empty
If (fecha = cont) Then
OF = Sheets("Tableau de donné").Cells(ligne, 2).Value
Message = Message & vbNewLine & OF
End If
ligne = ligne + 1
Wend
Message = Message & vbNewLine & vbNewLine
Message = Message & "Cordialement"
Set MItem = OutlookApp.CreateItem(olMailItem)
With Item
.To = Dest
.CC = ""
.BCC = ""
.Subject = Sujet
.Body = Message
End With
End Sub
Prueba este código...
Lo que hice fue sustituir el bucle de While...Wend (que a mi no me gusta para nada, lo evito siempre que puedo) por un For Each...Next
También cambé un poco algunas partes del procedimiento que en mi opinión podían mejorarse.
No tengo outlook en esta PC, no lo pude probar, pero debería funcionar. De todas formas yo no uso Outlook para mandar emails por VBA, prefiero usar CDO.
Este es el código:
Sub EnvoyerMail()
'variables del objeto outlook
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
'variables para la busqueda de la fecha
Dim Mail As Worksheet: Set Mail = Sheets("Mail")
Dim TableauDeDonne As Worksheet: Set TableauDeDonne = Sheets("tableau de donné")
Dim MailDate As Date: MailDate = Mail.Range("G1").Value
Dim rCell As Range, rRng As Range
Dim uF As Long: uF = TableauDeDonne.Range("DE" & Rows.Count).End(xlUp).Row
Set rRng = TableauDeDonne.Range("DE2:DE" & uF)
'variables para el email
Dim Dest As String: Dest = Mail.Cells(2, 7)
Dim OF As String
Dim Messg As String: Messg = "Caroline, j'ai besoin d'imprimmer les étiquettes correspondant aux OF suivants:"
For Each rCell In rRng.Cells
If rCell.Value = MailDate Then
OF = OF & vbCr & TableauDeDonne.Cells(rCell.Row, 2)
End If
Next rCell
Messg = Messg & OF & vbCr & vbCr & "Cordialement"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Dest
.CC = ""
.BCC = ""
.Subject = "Liste OF à imprimer"
.Body = Messg
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End SubAndy
Muchísimas gracias !
Funciona perfecto :)
Una ultima consulta, ¿cómo podría hacer para que se escriba automático el mail pero que no se envíe directamente? ¿Si no que me deje abierto el mail por si quiero agregar algo más? ¿solo saco el .Send?
Gracias de nuevo
Cambia .Send por .Display
Si mal no recuerdo eso hace lo que quieres.
