Save and Send Macro - Determine importance based on cell value

sacastiglia

New Member
Joined
Jul 29, 2014
Messages
23
Hello,

I have a save and send macro that will send a timesheet with no importance noted. I would like to send this email with high importance only if any cell in range P6 thru P11 is greater than 10 or change the subject line font color to red.

Any help would be greatly appreciated.

My code is shown below:

HTML:
Option Explicit
Sub Mail_Workbook_Outlook_2()
' TX
    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim DatePicked As String
    Dim PcName As String
    Dim SavedName1 As String
    Dim SavedName2 As String
    Dim SavedName3 As String
    Dim SavedName4 As String
    Dim SavedName5 As String
    Dim SavedName6 As String
    Dim SavedName7 As String
    Dim ws As Worksheet
    
DatePicked = Worksheets("BLANK").Range("C5").Value
PcName = Worksheets("BLANK").Range("C4").Value
SavedName1 = Worksheets("BLANK").Range("E6").Value
SavedName2 = Worksheets("BLANK").Range("E7").Value
SavedName3 = Worksheets("BLANK").Range("E8").Value
SavedName4 = Worksheets("BLANK").Range("E9").Value
SavedName5 = Worksheets("BLANK").Range("E10").Value
SavedName6 = Worksheets("BLANK").Range("E11").Value
SavedName7 = Worksheets("BLANK").Range("C6").Value
    Set wb1 = ActiveWorkbook
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    ' Make a copy of the file.
    ' If you want to change the file name then change only TempFileName variable.
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Copy of " & wb1.Name
        FileExtStr = "." & LCase(Right(wb1.Name, _
                                   Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))
    wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
    Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)
    Set OutApp = CreateObject("Outlook.Application")
    
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
   ' Change the mail address and subject in the macro before you run this procedure.
    With OutMail
        .To = "abc@abc.com"
        .CC = ""
        .BCC = ""
        .Importance = "olImportanceHigh"
        .Subject = PcName & "-" & DatePicked & " for Job #: " & SavedName7 & ":  " & SavedName1 & " - " & SavedName2 & " - " & SavedName3 & " - " & SavedName4 & " - " & SavedName5 & " - " & SavedName6
        '.Subject = "NEW ACCESS REQUEST & VendorName & DatePicked"
        .Body = "Daily Foreman Report Attached"
        'VendorName = Worksheets("Sheet1").Range("G12").Value
        .Attachments.Add wb2.FullName
        ' You can add other files by uncommenting the following line.
        '.Attachments.Add ("C:\test.txt")
        ' In place of the following statement, you can use ".Display" to
        ' display the mail.
        .Importance = 2
        .Display
    End With
    
    On Error GoTo 0
    wb2.Close SaveChanges:=False
    ' Delete the file.
    Kill TempFilePath & TempFileName & FileExtStr
    Set OutMail = Nothing
    Set OutApp = Nothing
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
End With
Sheets("BLANK").Range("C4:C11").ClearContents
Sheets("BLANK").Range("E6:M11").ClearContents
Sheets("BLANK").Range("D17:D24").ClearContents
Sheets("BLANK").Range("H17:J40").ClearContents
Sheets("BLANK").Range("O17:P21").ClearContents
Sheets("BLANK").Range("O24:P28").ClearContents
ActiveSheet.Shapes("TEXAS").Visible = False
End Sub
 

Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand

Forum statistics

Threads
1,195,949
Messages
6,012,478
Members
441,701
Latest member
vnkendijs

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top