2 Attachment(s)
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.
Code:
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
