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-pro...end-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