Chosing Attachment Based On Condition Before Sending Mail In Outlook

[jja082]

Hi,

I have a Macro for sending outlook, but i want to modify it using attached mail templates:

Template 1, if there is 1 item that is more than 30 days (column C)
Template 2, if there are 2 or more items that are more than 30 days
Template 3, if there is no item that is more than 30 days.

Subject also varies depending on the template.

Thanks,

AkiOutlook sending2.xlsSample templates.docxSample mails.xlsx

[Excel Fox]

This should do most of the work.

Option Explicit
Sub Send_Row_Or_Rows_1()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
    Dim OutApp As Object
    Dim OutMail As Object
    Dim rng As Range
    Dim Ash As Worksheet
    Dim Cws As Worksheet
    Dim Rcount As Long
    Dim Rnum As Long
    Dim FilterRange As Range
    Dim FieldNum As Integer
    Dim mailAddress As String
    Dim strSituation As String
    Dim lngOutlier As Long
    On Error GoTo cleanup
    Set OutApp = CreateObject("Outlook.Application")
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    'Set filter sheet, you can also use Sheets("MySheet")
    Set Ash = ActiveSheet
    Ash.AutoFilterMode = False
    'Set filter range and filter column (Column with names)
    Set FilterRange = Ash.Range("A1:G" & Ash.Cells(Rows.Count, 1).End(xlUp).Row)
    FieldNum = 1    'Filter column = A because the filter range start in A
    'Add a worksheet for the unique list and copy the unique list in A1
    Set Cws = Worksheets.Add
    FilterRange.Columns(FieldNum).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=Cws.Range("A1"), _
            CriteriaRange:="", Unique:=True
    'Count of the unique values + the header cell
    Rcount = Cws.UsedRange.Rows.Count
    'If there are unique values start the loop
    If Rcount >= 2 Then
        For Rnum = 2 To Rcount
            'Filter the FilterRange on the FieldNum column
            FilterRange.AutoFilter Field:=FieldNum, Criteria1:=Cws.Cells(Rnum, 1).Value
            lngOutlier = WorksheetFunction.CountIfs(FilterRange.Columns(1).Cells, Cws.Cells(Rnum, 1).Value, FilterRange.Columns(3).Cells, ">30")
            Select Case lngOutlier
                Case Is >= 1
                    strSituation = ">30"
                Case Else
                    lngOutlier = WorksheetFunction.CountIfs(FilterRange.Columns(1).Cells, Cws.Cells(Rnum, 1).Value, FilterRange.Columns(3).Cells, "<=30")
                    strSituation = "<=30"
            End Select
            'Look for the mail address in the MailInfo worksheet
            mailAddress = ""
            On Error Resume Next
            mailAddress = Application.WorksheetFunction. _
                          VLookup(Cws.Cells(Rnum, 1).Value, _
                                Worksheets("Mailinfo").Range("A1:B" & _
                                Worksheets("Mailinfo").Rows.Count), 2, False)
            On Error GoTo 0
            If mailAddress <> "" Then
                With Ash.AutoFilter.Range
                    On Error Resume Next
                    Set rng = .SpecialCells(xlCellTypeVisible)
                    On Error GoTo 0
                End With
                Set OutMail = OutApp.CreateItem(0)
                On Error Resume Next
                With OutMail
                    .To = mailAddress
                    .Subject = "Test mail"
                    .body = MesgToPass(strSituation, lngOutlier)
                    .htmlbody = .htmlbody & RangetoHTML(rng) & MesgToPass("")
                    .Display  'Or use Send
                End With
                On Error GoTo 0
                Set OutMail = Nothing
            End If
            'Close AutoFilter
            Ash.AutoFilterMode = False
        Next Rnum
    End If
cleanup:
    Set OutApp = Nothing
    Application.DisplayAlerts = False
    Cws.Delete
    Application.DisplayAlerts = True
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub
Function MesgToPass(strSituation As String, Optional lngOutlier As Long)
    Dim str As String
    
    Select Case strSituation
        Case ">30"
        If lngOutlier > 1 Then
            str = "Hi Dear,"
            str = str & vbCrLf & ""
            str = str & vbCrLf & "We have " & lngOutlier & " open workflows which are open in the system for more than 30 days and were located in your inbox."
            str = str & vbCrLf & ""
            str = str & vbCrLf & "Have included workflows with average duration of 0-30 days so as not to wait for them to be delayed before we send another reminder. Kindly provide your support in closing/processing these open items as soon as possible. Our goal is to have no open workflow over 30 days. Please give advice if you're unable to do so due to some issues you're encountering. If workflow is incorrectly sent to your inbox, please advise workflow number and forwarder."
        ElseIf lngOutlier = 1 Then
            str = str & "Hi Dear,"
            str = str & vbCrLf & ""
            str = str & vbCrLf & "We have 1 open workflow which is open in the system for more than 30 days and is located in your inbox."
            str = str & vbCrLf & ""
            str = str & vbCrLf & "Kindly provide your support in closing/processing this open item as soon as possible. Our goal is to have no open workflow over 30 days. Please give advice if you're unable to do so due to some issues you're encountering. If workflow is incorrectly sent to your inbox, please advise workflow number and forwarder."
        End If
        Case "<=30"
            str = str & "Hi Dear,"
            str = str & vbCrLf & ""
            str = str & vbCrLf & "See below workflows with average duration of 0-30 days that are located in your inbox and kindly prioritize these so it won't be delayed before we send another reminder. Please provide your support in closing/processing these open items as soon as possible. If workflow is incorrectly sent to your inbox, please advise workflow number and forwarder."
        Case Else
            str = str & vbCrLf & "<P><FONT FACE=""Calibri"">"
            str = str & vbCrLf & ""
            str = str & vbCrLf & ""
            str = str & vbCrLf & "Hoping for your utmost cooperation."
            str = str & vbCrLf & "<P><P></P></P>"
            str = str & vbCrLf & "Thank you and Best Regards,</FONT></P>"
        End Select
        MesgToPass = str
        
End Function

[jja082]

Thank you for the help, but i still have one question, what if the subject changed depending also on the template to be sent.

1. if there are 2 or more items that are more than 30 day: the subject is "Multiple workflows with more than 30 days"
2. if only one item is more than 30 days: "Single WF with more than 30 days"
3. if no more thank 30 days: "Workflows without more than 30days"

Thanks in advance

[Excel Fox]

Add this to the module

Function SubjToPass(strSituation As String, Optional lngOutlier As Long)

    Dim str As String
    Select Case strSituation
        Case ">30"
        If lngOutlier > 1 Then
            SubjToPass = "Multiple workflows with more than 30 days"
        ElseIf lngOutlier = 1 Then
            SubjToPass = "Single WF with more than 30 days"
        End If
        Case "<=30"
            SubjToPass = "Workflows without more than 30days"
        End Select
        
End Function

And in the subject line, use

.Subect = SubjToPass(strSituation, lngOutlier)

[jja082]

I have edited the macro, but when i save the macro to our shared folders, the macro won't work, do you have idea why? also there are cases which the macro work,

1. if i create a new file, copying all macro, then it works, but when i transfered or save the file from ather share folders, the macro is not working.
2. if it is save and wont work, i am running the VBA, then the open sheet is "Mailinfo" the macro is running but it copies the date from the said sheet.