Results 1 to 5 of 5

Thread: Send Automatic Reminder Mails Row By Row Based On Status

  1. #1
    Junior Member
    Join Date
    Aug 2013
    Posts
    19
    Rep Power
    0

    Question

    Help Me
    Hello Gurus

    I was added macro with the base on rondebruin, but it is not fit to me. I also checked post related to me @ excelforum, but not getting perfect solution.
    I am not familiar with the tools, macros & VB. If anyone helps me to solve the situation, it will help me a lot.

    Scenario
    Attached Files Attached Files

  2. #2
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    Which email client are you using?
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  3. #3
    Junior Member
    Join Date
    Aug 2013
    Posts
    19
    Rep Power
    0
    email client is outlook 2010.

    Thanks for your prompt reply, and sorry for forgot to update email client.

  4. #4
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    Here's the code. I've also attached the sample workbook.

    Code:
    Option Explicit
    
    'Requirement: Outlook needs to be loaded, and account logged in
    
    Sub CallMailer()
        
        Dim lngLoop As Long 'Programming ethics 1. Always start your first line after leaving a line space, and 1 indentation level
        Dim varEmailList As Variant
        Dim strSendTo As String
        Dim blnSend As Boolean
        
        With Worksheets("Sheet2")
            varEmailList = .Range("A2:B" & .Cells(.Rows.Count, 1).End(xlUp).Row)
        End With
        With ActiveSheet
            For lngLoop = 4 To .Cells(Rows.Count, 1).End(xlUp).Row ' Programming ethics 3. Always indent your loops, case statements and with constructors
                strSendTo = Application.VLookup(.Cells(lngLoop, "E").Value, varEmailList, 2, 0)
                If strSendTo <> vbNullString Then
                    If .Cells(lngLoop, "J").Value <> True And .Cells(lngLoop, "H").Value = Date Then
                        .Cells(lngLoop, "J").Value = True
                        blnSend = True
                    ElseIf .Cells(lngLoop, "K").Value <> True And .Cells(lngLoop, "I").Value = Date Then
                        .Cells(lngLoop, "K").Value = True
                        blnSend = True
                    End If
                    If blnSend Then
                        Call SendMessage(strTo:=strSendTo, strMessage:=CustMsg(.Cells(lngLoop, 2).Value, .Cells(lngLoop, 4).Value), strSubject:=.Cells(lngLoop, 3).Value, blnShowEmailBodyWithoutSending:=False, blnSignature:=True)
                        blnSend = False
                    End If
                End If
                strSendTo = vbNullString
            Next lngLoop
        End With 'Programming ethics 2. Always end your last line leaving a line space before ending the sub or function, and having indendation level of 1
        
    End Sub
    
    Function CustMsg(strB As String, strD As String)
    
        Dim str As String
        str = "Hi," & vbLf & vbLf
        str = str & "This is regarding " & strB & ", " & strD & "."
        str = str & vbLf & vbLf
        CustMsg = str & "It is a gentle reminder. If you have any query, please let me know."
        
    End Function
    The send mail function which is more generic was picked from another thread in this forum. This is what it is

    Code:
    Option Explicit
    
    Function SendMessage(strTo As String, Optional strCC As String, Optional strBCC As String, Optional strSubject As String, Optional strMessage As String, Optional rngToCopy As Range, Optional strAttachmentPath As String, Optional blnShowEmailBodyWithoutSending As Boolean = False, Optional blnSignature As Boolean)
         
        Dim objOutlook As Object 'Outlook.Application
        Dim objOutlookMsg As Object 'Outlook.MailItem
        Dim objOutlookRecip As Object 'Outlook.Recipient
        Dim objOutlookAttach As Object 'Outlook.Attachment
        Dim lngLoop As Long
        Dim strSignature As String
         
        If Trim(strTo) & Trim(strCC) & Trim(strBCC) = "" Then
            MsgBox "Please provide a mailing address!", vbInformation + vbOKOnly, "Missing mail information"
            Exit Function
        End If
        
        'Create the Outlook session.
        On Error Resume Next
        Set objOutlook = GetObject(, "Outlook.Application")
        Err.Clear: On Error GoTo -1: On Error GoTo 0
        If objOutlook Is Nothing Then
            Set objOutlook = CreateObject("Outlook.Application")
        End If
         
        'Create the message.
        Set objOutlookMsg = objOutlook.CreateItem(0)
    
        With objOutlookMsg
            
            'Add the To recipient(s) to the message.
            For lngLoop = LBound(Split(strTo, ";")) To UBound(Split(strTo, ";"))
                If Trim(Split(strTo, ";")(lngLoop)) <> "" Then
                    Set objOutlookRecip = .Recipients.Add(Trim(Split(strTo, ";")(lngLoop)))
                    objOutlookRecip.Type = 1 'olTO
                End If
            Next lngLoop
             
            'Add the CC recipient(s) to the message.
            For lngLoop = LBound(Split(strCC, ";")) To UBound(Split(strCC, ";"))
                If Trim(Split(strCC, ";")(lngLoop)) <> "" Then
                    Set objOutlookRecip = .Recipients.Add(Trim(Split(strCC, ";")(lngLoop)))
                    objOutlookRecip.Type = 2 'olCC
                End If
            Next lngLoop
             
            'Add the BCC recipient(s) to the message.
            For lngLoop = LBound(Split(strBCC, ";")) To UBound(Split(strBCC, ";"))
                If Trim(Split(strBCC, ";")(lngLoop)) <> "" Then
                    Set objOutlookRecip = .Recipients.Add(Trim(Split(strBCC, ";")(lngLoop)))
                    objOutlookRecip.Type = 3 'olBCC
                End If
            Next lngLoop
             
            'Set the Subject, Body, and Importance of the message.
            If strSubject = "" Then
                strSubject = "This is an Automation test with Microsoft Outlook"
            End If
            .Subject = strSubject
            If strMessage = "" Then
                strMessage = "This is the body of the message." & vbCrLf & vbCrLf
            End If
            .Importance = 2 'High importance
            If Not strMessage = "" Then
                .Body = strMessage & vbCrLf & vbCrLf
            End If
            
            If Not rngToCopy Is Nothing Then
                .HTMLBody = .Body & RangetoHTML(rngToCopy)
            End If
             
            'Add attachments to the message.
            If Not strAttachmentPath = "" Then
                If Len(Dir(strAttachmentPath)) <> 0 Then
                    Set objOutlookAttach = .Attachments.Add(strAttachmentPath)
                Else
                    MsgBox "Unable to find the specified attachment. Sending mail anyway."
                End If
            End If
            
            If blnSignature Then
                'Win XP
                strSignature = Environ("USERPROFILE") & "\Application Data\Microsoft\Signatures\*.htm"
                strSignature = Environ("USERPROFILE") & "\Application Data\Microsoft\Signatures\" & Dir(strSignature)
                If Dir(strSignature) = "" Then
                'Win 7
                    strSignature = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Signatures\*.htm"
                    strSignature = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Signatures\" & Dir(strSignature)
                End If
            End If
             
            If Dir(strSignature) <> "" Then
                strSignature = GetBoiler(strSignature)
            Else
                strSignature = ""
            End If
            
            'MsgBox .htmlbody
            If strSignature <> "" Then
                .HTMLBody = .HTMLBody & strSignature
            End If
                
            'Resolve each Recipient's name.
            For Each objOutlookRecip In .Recipients
                objOutlookRecip.Resolve
            Next
             
            'Should we display the message before sending?
            If blnShowEmailBodyWithoutSending Then
                .Display
            Else
                .Display
                .Save
                .Send
            End If
        End With
         
        Set objOutlook = Nothing
        Set objOutlookMsg = Nothing
        Set objOutlookAttach = Nothing
        Set objOutlookRecip = Nothing
         
    End Function
    
    Function RangetoHTML(rng As Range)
    
        'Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
        Dim strTempFile As String
        Dim wbkTemp As Workbook
    
        strTempFile = Environ$("temp") & Application.PathSeparator & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
     
        'Copy the range and create a workbook to receive the data.
        rng.Copy
        Set wbkTemp = Workbooks.Add(1)
        With wbkTemp.Sheets(1)
            With .Cells(1)
                .PasteSpecial Paste:=8
                .PasteSpecial xlPasteValues, , False, False
                .PasteSpecial xlPasteFormats, , False, False
                .Select
            End With
            Application.CutCopyMode = False
            On Error Resume Next
                .DrawingObjects.Visible = True
                .DrawingObjects.Delete
            Err.Clear: On Error GoTo 0
        End With
     
        'Publish the sheet to an .htm file.
        With wbkTemp.PublishObjects.Add( _
             SourceType:=xlSourceRange, _
             Filename:=strTempFile, _
             Sheet:=wbkTemp.Sheets(1).Name, _
             Source:=wbkTemp.Sheets(1).UsedRange.Address, _
             HtmlType:=xlHtmlStatic)
            .Publish (True)
        End With
     
        'Read all data from the .htm file into the RangetoHTML subroutine.
        RangetoHTML = GetBoiler(strTempFile)
        RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                              "align=left x:publishsource=")
     
        'Close wbkTemp
        wbkTemp.Close savechanges:=False
     
        'Delete the htm file.
        Kill strTempFile
     
        Set wbkTemp = Nothing
        
    End Function
    
    Function GetBoiler(ByVal strFile As String) As String
    
        'May not be supported in MAC
        Dim objFSO As Object
        Dim objTextStream As Object
        On Error Resume Next
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        Set objTextStream = objFSO.GetFile(strFile).OpenAsTextStream(1, -2)
        GetBoiler = objTextStream.ReadAll
        objTextStream.Close
        
        Set objFSO = Nothing
        Set objTextStream = Nothing
        
    End Function
    Attached Files Attached Files
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  5. #5
    Junior Member
    Join Date
    Aug 2013
    Posts
    19
    Rep Power
    0
    Hi,

    Regret to not answering instantly. But after getting your code, my first reaction is "AWESOME".

    It's AWESOME and working fabulous. What efforts you put to create the code it's really helping me a lot.

    I appreciate the knowledge you have in excel & MACROS

    Thanks Thanks Thanks


    Regards

    Amar K

Similar Threads

  1. Send Multiple Outlook Mails Using The Same Template
    By forums1167 in forum Excel Help
    Replies: 1
    Last Post: 07-20-2013, 03:13 PM
  2. Replies: 4
    Last Post: 03-22-2013, 01:47 PM
  3. Autofill the data based on non blank cell in next row?
    By Rajesh Kr Joshi in forum Excel Help
    Replies: 3
    Last Post: 11-29-2012, 04:16 PM
  4. how to send each row by email
    By BARIS in forum Excel Help
    Replies: 22
    Last Post: 09-19-2012, 09:42 PM
  5. Replies: 11
    Last Post: 11-10-2011, 12:32 AM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •