Create Weather Report Dashboard and Send Email

[gmayor]

Code revised to loop through recipients - see attached

Sub SendReport()
'Graham Mayor - https://www.gmayor.com - Last updated - 03 Apr 2020
'Requires the code from http://www.rondebruin.nl/win/s1/outlook/openclose.htm to start Outlook
Dim olApp As Object
Dim oItem As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
Dim xlSheet As Worksheet
Dim LastRow As Long
Dim lngRow As Long

    'Copy the chart
    Set xlSheet = Sheets("Weather Report")
    xlSheet.Activate
    Range("Print_Area").Copy
    Set xlSheet = Sheets("Email Sheet")
    With xlSheet
        LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
    End With

    Set olApp = OutlookApp()

    With xlSheet
        LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
    End With
    For lngRow = 3 To LastRow
        'Create a new mailitem for each item
        Set oItem = olApp.CreateItem(0)
        With oItem
            'add the recipient from column 3
            .Recipients.Add(xlSheet.Cells(lngRow, 3)).Type = 1
            'add the associated CC from column 5 (if more than one put them in the same cell separated by semicolons)
            .Recipients.Add(xlSheet.Cells(lngRow, 5)).Type = 2
            .Subject = "Weather report on " & " " & Format(Now, "dd-mmm-yy")
            .BodyFormat = 2    'html
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor
            Set oRng = wdDoc.Range
            oRng.collapse 1
            'add the text before the chart
            oRng.Text = "Dear Sir," & vbCrLf & vbCrLf & _
                        "Please find the attachment weather report on" & " " & _
                        Format(Now, "dd-mmm-yy") & " " & _
                        "at 05:00 hrs." & vbCrLf & vbCrLf
            oRng.collapse 0
            'paste the chart
            oRng.Paste
            oRng.collapse 0
            'add the text after the chart
            oRng.Text = vbCr & "Regards"
            .Display    'This line is required
            '.Send 'remove apostrophe after testing
        End With
    Next lngRow

    'Clean up
    Set oItem = Nothing
    Set olApp = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
lbl_Exit:
    Exit Sub
End Sub