Create Weather Report Dashboard and Send Email

[sathishsusa]

Dear Sir,

I am trying to create a weather Dashboard report and save PDF to send Email to all my Managers.

I took some code in forum to create PDF and sending Email list in Email Sheet. i can able to create PDF on Today date by filename but i cant able to send outlook with file attachment not attached also Email address of To & CC.

Kindly please help to modify or give me a new solution to create PDF file & send email.

Data Sheet: if i enter the values in data sheet to display in weather Report dashboard on daily basis. please give your idea how to make it.

Thanks,

cross post : https://www.excelforum.com/excel-programming-vba-macros/1310937-create-weather-report-dashboard-and-send-email.html

i didnt get any positive response from other forums. so kindly please solve this problems.




Option Explicit


Sub PDFweatherActiveSheet()


Dim ws As Worksheet
Dim strPath As String
Dim myFile As Variant
Dim strFile As String
Dim outlapp As Object
On Error GoTo errHandler


Set ws = ActiveSheet


'enter name and select folder for file
' start in current workbook folder
strFile = Replace(Replace(ws.Name, " ", ""), ".", "_") _
& "_" _
& Format(Now(), "dd-mmm- yyyy") & ".pdf"

strFile = ThisWorkbook.path & "\" & strFile


myFile = Application.GetSaveAsFilename _
(InitialFileName:=strFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")


If myFile <> "False" Then
ws.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
ignoreprintareas:=False, _
openafterpublish:=True


MsgBox "PDF file has been created."
End If


exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
Call SendEmail
End Sub




Sub SendEmail()
Dim OutlookApp As Object
Dim MItem As Object
Dim Cell As Range
Dim email_ As String
Dim cc_ As String
Dim subject_ As String
Dim body_ As String
Dim i As Integer
Dim ws As Worksheet

'Create Outlook object
Set OutlookApp = CreateObject("Outlook.Application")


Dim Rg As Range
Dim Rg2 As Range
Dim SaveToRg As Range
Dim SaveToRg2 As Range
Dim Txt As String
'Dim Cell As Range
Dim TStr As String
Dim TStr2 As String
On Error Resume Next

Set Rg = Application.Range("C3:C22")
Set Rg2 = Application.Range("E3:E22")

Set SaveToRg = ActiveSheet.Range("K1")
Set SaveToRg2 = ActiveSheet.Range("K2")

Set SaveToRg = SaveToRg.Cells(1)
Set SaveToRg2 = SaveToRg.Cells(2)

Application.ScreenUpdating = False



For Each Cell In Rg
If Cell <> "" Then
TStr = TStr & Cell & " "
Else
SaveToRg.Value = TStr
Set SaveToRg = SaveToRg.Offset(1)
TStr = ""
End If
Next

If TStr <> "" Then SaveToRg2.Value = Left(TStr, Len(TStr) - 1)

For Each Cell In Rg2
If Cell <> "" Then
TStr2 = TStr2 & Cell & " "
Else
SaveToRg2.Value = TStr2
Set SaveToRg2 = SaveToRg2.Offset(1)
TStr2 = ""
End If
Next

If TStr2 <> "" Then SaveToRg2.Value = Left(TStr2, Len(TStr2) - 1)

Application.ScreenUpdating = True






'Loop through the rows
For Each Cell In Range("A3:A22").Cells.SpecialCells(xlCellTypeConstants)
If Cell.Value <> "" Then
email_ = ActiveSheet.Range("K1")
subject_ = "Weather report on " & " " & Format(Now, "dd-mmm-yy")
body_ = "Dear Sir," & vbCrLf & vbCrLf & _
"Please find the attachment weather report on" & " " & Format(Now, "dd-mmm-yy") & " " & "at 05:00 hrs." & vbCrLf & vbCrLf & _
"Regards,"


cc_ = ActiveSheet.Range("K2")

'Create Mail Item and send it
Set MItem = OutlookApp.CreateItem(0)
With MItem
.To = email_
.CC = cc_
.Subject = subject_
.Body = body_
.Attachments.Add Environ("USERPROFILE") & "\Desktop\Weather Report\" & "Weather Report" & " " & Format(Now, "dd-mmm-yy").pdf
.Display
End With
End If
Next

ActiveSheet.Range("K1").Value = ""
ActiveSheet.Range("K2").Value = ""


Dim aFile As String


aFile = Environ("USERPROFILE") & "\Desktop\Weather Report*.pdf"
If Len(Dir$(aFile)) > 0 Then
Kill aFile
End If


End Sub

[gmayor]

What I think you want is as follows. Use the code from http://www.rondebruin.nl/win/s1/outlook/openclose.htm to start Outlook


Sub SendReport()
Dim olApp As Object
Dim oItem As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
'Create a new mailitem
Range("Print_Area").Copy
Set olApp = OutlookApp()
Set oItem = olApp.CreateItem(0)
With oItem
.BodyFormat = 2
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
oRng.collapse 1
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
oRng.Paste
oRng.collapse 0
oRng.Text = vbCr & "Regards"
.To = ActiveSheet.Range("K1")
.Subject = "Weather report on " & " " & Format(Now, "dd-mmm-yy")
.Display
End With

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

[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

[sathishsusa]

Dear gmayor,

Thank you so much for your Great help i been waiting for long days to anyone come out with solution for this finally i got your code and help it works well. even without PDF attach file its pasting on Outlook body i liked it.

Try to solve few issues on it.

1. when click on send mail its showing multiple windows to open with each Recipients of TO & CC.

26264


possible to send one mail to add all To & CC address in one mail sir.

26266

2. When pasting on outlook body the picture moves out of box sir how to solve it.

26265

Thanks a lot for your time given up to me sir..