Consulting

Results 1 to 4 of 4

Thread: Create Weather Report Dashboard and Send Email

  1. #1

    Lightbulb Create Weather Report Dashboard and Send Email

    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
    Attached Images Attached Images
    Attached Files Attached Files

  2. #2
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    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
    Attached Files Attached Files
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  4. #4
    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.

    multiple window.jpg


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

    recipotant.jpg

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

    picture out.jpg

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

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •