Enviar correo a traves de outlook según fecha

[pititor]

Hola a todos,

Estoy intentando crear macro de envío correo electrónico a través de OutLook a los destinatarios de la columna B si la fecha de revisión que está en la columna E es mayor de 2 años con respecto a la fecha actual. Envío archivo de prueba

Gracias

envio correo.zip

[logroastur]

Buenas utiliza

Sub EnviaRevision()
    Dim d1              As Double
    Dim d2              As Double
    Dim d               As Long
    Dim i               As Long
    Dim j               As Long
    Dim u               As Long
    Dim obj             As Object
    Dim tBody           As String
    Dim tTito           As String
    Dim tDest           As String
    Dim vSend           As Integer
    On Error Resume Next
    d1 = Date
    tTito = "Este es un mensaje desde excel"
    tBody = "Esta enviado desde Excel"
    'TIPO DE ENVIO
        '-1- AUTOMATICAMENTE
        '-0- MANUALMENTE Y ARCHIVADO EN BORRADOR
    vSend = 0
    With Hoja1
        u = .Range("A" & .Rows.Count).End(xlUp).Row
        If u < 2 Then
            MsgBox "Sin datos a evaluar"
            Exit Sub
        End If
        Set obj = GetObject("Outlook.Application")
        If Err.Number <> 0 Then
            Set obj = CreateObject("Outlook.Application")
            Err.Clear
        End If
        For i = 2 To u
            d2 = .Range("E" & i).Value
            d = DateDiff("yyyy", d2, d1)
            If d >= 2 Then
                tDest = .Range("B" & i)
                With obj
                    With .CreateItem(0)
                        .To = tDest
                        .CC = ""
                        .BCC = ""
                        .Subject = tTito
                        .Body = tBody & vbNewLine & vbNewLine & " REVISIÓN CADUCADA " & vbNewLine & vbNewLine & "ULIMA REALIZADA " & d & " MESES ANTES"
                        If vSend = 1 Then
                            .Send
                        Else
                            .Save
                            .Display
                        End If
                    End With
                    j = j + 1
                End With
            End If
        Next i
        Set obj = Nothing
    End With
    If j = 0 Then
        MsgBox "No existen emails a enviar", vbInformation, Application.OrganizationName
    Else
        MsgBox "Se produjeron " & j & " emails a enviar", vbInformation, Application.OrganizationName
    End If
End Sub

Un saludo

[pititor]

Hola,

He estado probando el código, el mensaje que envía es Esta enviado desde Excel

REVISIÓN CADUCADA

ULTIMA REALIZADA 2 MESES ANTES

y deben ser 24 meses. He ido probando con diferentes fechas y no me calcula los 24 meses correctamentete.

Una cosa importante que no había tenido encuenta es decir en el mail que doc. Es el que pasa de los 24 meses sin revisión, tambien debería aparecer en el mail. Envío archivo modificado con una columna nueva. En la columna A he puesto documento y en mensaje debería aparecer que el documento X ha sido revisado hace ya 24 meses se ruega proceda a su revisión.

Gracias.

envio correo modificado.zip

[logroastur]

Buenas

Para ver los posibles argumentos de la función DateDiff usa lo siguiente

Sub LosIntervalosDatos()
    Debug.Print "Años           " & vbTab & Format(DateDiff("yyyy", Range("F2"), Date, vbMonday), "00")
    Debug.Print "Dias Año       " & vbTab & Format(DateDiff("y", Range("F2"), Date, vbMonday), "00")
    Debug.Print "Meses          " & vbTab & Format(DateDiff("m", Range("F2"), Date, vbMonday), "00")
    Debug.Print "Dias           " & vbTab & Format(DateDiff("d", Range("F2"), Date, vbMonday), "00")
    Debug.Print "Quinqueños     " & vbTab & Format(DateDiff("q", Range("F2"), Date, vbMonday), "00")
    Debug.Print "Dia de semana  " & vbTab & Format(DateDiff("w", Range("F2"), Date, vbMonday), "00")
    Debug.Print "Semanas        " & vbTab & Format(DateDiff("ww", Range("F2"), Date, vbMonday), "00")
    Debug.Print "Horas          " & vbTab & Format(DateDiff("h", Range("F2"), Date, vbMonday), "00")
    Debug.Print "Minutos        " & vbTab & Format(DateDiff("n", Range("F2"), Date, vbMonday), "00")
    Debug.Print "Segundos       " & vbTab & Format(DateDiff("s", Range("F2"), Date, vbMonday), "00")
End Sub

Para colocar el mensaje del texto utiliza

Sub EnviaRevision()
    Dim d1              As Double
    Dim d2              As Double
    Dim d               As Long
    Dim i               As Long
    Dim j               As Long
    Dim u               As Long
    Dim obj             As Object
    Dim tBody           As String
    Dim tTito           As String
    Dim tDest           As String
    Dim vSend           As Integer
    Dim tMensa          As String
    Dim tMensa1         As String
    Dim tMensa2         As String
    On Error Resume Next
    d1 = Date
    tTito = "Este es un mensaje desde excel"
    tBody = "Esta enviado desde Excel"
    tMensa1 = "El documento "
    tMensa2 = " ha sido revisado hace ya 24 meses se ruega proceda a su revisión."
    'TIPO DE ENVIO
        '-1- AUTOMATICAMENTE
        '-0- MANUALMENTE Y ARCHIVADO EN BORRADOR
    vSend = 1
    With Hoja1
        u = .Range("A" & .Rows.Count).End(xlUp).Row
        If u < 2 Then
            MsgBox "Sin datos a evaluar"
            Exit Sub
        End If
        Set obj = GetObject("Outlook.Application")
        If Err.Number <> 0 Then
            Set obj = CreateObject("Outlook.Application")
            Err.Clear
        End If
        For i = 2 To u
            d2 = .Range("F" & i).Value
            d = DateDiff("m", d2, d1, vbMonday)
            If d >= 24 Then
                tDest = .Range("C" & i)
                tMensa = tMensa1 & .Range("A" & i).Value & tMensa2 & vbNewLine & vbNewLine & _
                        "ULTIMA REALIZADA " & Format(d, "00") & " MESES ANTES"
                With obj
                    With .CreateItem(0)
                        .To = tDest
                        .CC = ""
                        .BCC = ""
                        .Subject = tTito
                        .Body = tBody & vbNewLine & vbNewLine & tMensa
                        If vSend = 1 Then
                            .Send
                        Else
                            .Save
                            .Display
                        End If
                    End With
                    j = j + 1
                End With
            End If
        Next i
        Set obj = Nothing
    End With
    If j = 0 Then
        MsgBox "No existen emails a enviar", vbInformation, Application.OrganizationName
    Else
        MsgBox "Se produjeron " & j & " emails a enviar", vbInformation, Application.OrganizationName
    End If
End Sub

Un saludo

[pititor]

Gracias por tu contestacion, lo probare y te comento

[pititor]

logroastur lo he probadoy funciona. se puede dar por solucionado el post. Gracias