VBA to email multiple ranges on a sheet.

[shophoney]

Hi,

I'm trying email multiple ranges from one sheet and can't figure out what I need to change. I pasted sample data her of my code.

Any help would be appreciated.

Also can't figure out why after I email my screen refresh seems messed up???

Sub CDO_Email_Hourly_Statistics()

Dim rng As Range
Dim rng1 As Range
Dim rng2 As Range
Dim iMsg As Object
Dim iConf As Object
Dim Flds As Variant

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")

iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "test@gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "blank"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.Update
End With

Set rng = Nothing
On Error Resume Next

Set rng = Sheets("Hourly Statistics").Range("A2:C50")
Set rng1 = Sheets("Hourly Statistics").Range("E2:G50")
Set rng2 = Sheets("Hourly Statistics").Range("E2:G50")

On Error GoTo 0

If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If

With iMsg
Set .Configuration = iConf
.BCC = "test@sss.COM"
'.CC = ""
.From = """No_reply"" <No_reply@xxxxx.com>"
.Subject = Format(Now, "ddd MMM dd/yy") & " - Hourly Statistics"
.HTMLBody = StrBody & RangetoHTML(rng) & RangetoHTML(rng1)
.Body = "Please note sales are a running total from 2022 at the same time of day."
.Send
End With

With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With

On Error Resume Next

If Err.Number <> 0 Then
MsgBox Err.Description, vbCritical, "There was an error"
Exit Sub
End If

' ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
' False, AllowFiltering:=True, AllowUsingPivotTables:=True

'''''testing
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With

End Sub