About Me

My photo
a Dynamic and Energetic guy.....

Thursday, October 6, 2011

Excel Macro To Send Emails Automatically

Option Explicit

Private Sub Worksheet_Calculate()
    Dim FormulaRange As Range
    Dim NotSentMsg As String
    Dim MyMsg As String
    Dim SentMsg As String
    Dim MyLimit As Date

    NotSentMsg = "Not Sent"
    SentMsg = "Sent"

    'Above the MyLimit value it will run the macro
    MyLimit = Date   //Set The Current Date

    'Set the range with Formulas that you want to check
    Set FormulaRange = Me.Range("J6:J60") //Date Range

    On Error GoTo EndMacro:
    For Each FormulaCell In FormulaRange.Cells
        With FormulaCell
            If IsDate(.Value) = False Then
                MyMsg = "Not a date"
            Else
                If .Value < MyLimit Then
                    MyMsg = SentMsg
                    If .Offset(0, 1).Value = NotSentMsg Then
                        Call Mail_with_outlook2  //Call To Send Emails
                    End If
                Else
                    MyMsg = NotSentMsg
                End If
            End If
            Application.EnableEvents = False
            .Offset(0, 1).Value = MyMsg
            Application.EnableEvents = True
        End With
    Next FormulaCell

ExitMacro:
    Exit Sub

EndMacro:
    Application.EnableEvents = True

    MsgBox "Some Error occurred." _
         & vbLf & Err.Number _
         & vbLf & Err.Description

End Sub
=================================================
Email Sending Part
=================================================
Sub Mail_with_outlook2()

    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

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    strto = Cells(FormulaCell.Row, "P").Value
    strcc = ""
    strbcc = ""
    strsub = "Do an update"
    strbody = "Hi " & Cells(FormulaCell.Row, "L").Value & vbNewLine & vbNewLine & _
              "Your expiry date is: " & Cells(FormulaCell.Row, "J").Value & vbNewLine & _
              "for the task of : " & Cells(FormulaCell.Row, "C").Value & _
              vbNewLine & vbNewLine & "Do an update" & _
              vbNewLine & vbNewLine & "Thanks." & _
              vbNewLine & vbNewLine & "Regards," & _
              vbNewLine & vbNewLine & "Marina Samaratunge"

    With OutMail
        .To = strto
        .CC = strcc
        .BCC = strbcc
        .Subject = strsub
        .Body = strbody
        'You can add a file to the mail like this
        '.Attachments.Add ("C:\test.txt")
        .Display    ' or use .Send
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

No comments:

My Masters