Click here to edit title

lets learn together

Download

Send Email Through VBA

Posted by [email protected] on March 17, 2017 at 11:15 AM

Option Explicit

 

Sub CreateEmail()

 


Dim sSubject As String

Dim sSend_From As String

Dim sSend_To As String

Dim sCc As String

Dim sBcc As String

Dim sBody As String

Dim objMail_Object As Object

Dim objMail_Single As Object

Dim rDist As Range

Dim wbDash As Workbook

Dim sTempFilePath As String

Dim sTempFileName As String

Dim sFileExt As String

 

With Application

.ScreenUpdating = False

.EnableEvents = False

End With

 

On Error GoTo ErrorHandle

 

Set wbDash = ActiveWorkbook

wbDash.Save

 

'Save temporary copy of the file

sTempFilePath = Environ$("temp") & "\"

sTempFileName = Format(Now, "dd-mmm-yy h-mm-ss") & " - " & wbDash.Name

wbDash.SaveCopyAs sTempFilePath & sTempFileName

 

'Define Email Attributes

sSubject = Format(Now, "dd-mmm-yy") & " - Daily FRC Report"

sSend_From = "[email protected]"

 

'Set Sent_To List

For Each rDist In [Data_Dist].Rows

If Intersect(rDist, [Data_Dist[To:]]).Value Like "*@*" Then

sSend_To = sSend_To & ";" & Intersect(rDist, [Data_Dist[To:]]).Value

End If

Next

'Set Sent_To List

For Each rDist In [Data_Dist].Rows

If Intersect(rDist, [Data_Dist[CC:]]).Value Like "*@*" Then

sCc = sCc & ";" & Intersect(rDist, [Data_Dist[CC:]]).Value

End If

Next

'Set Sent_To List

For Each rDist In [Data_Dist].Rows

If Intersect(rDist, [Data_Dist[BCC:]]).Value Like "*@*" Then

sBcc = sBcc & ";" & Intersect(rDist, [Data_Dist[BCC:]]).Value

End If

Next

 

'Set Body of email

sBody = "Hi All," & _

"

Please find the latest status update for the FRC project attached." & _

"
Please let us know if there are any questions or concerns." & _

"

Kind Regards."

 

'Create Email

Set objMail_Object = CreateObject("Outlook.Application")

Set objMail_Single = objMail_Object.CreateItem(0)

 

With objMail_Single

.Subject = sSubject

.To = sSend_To

.cc = sCc

.BCC = sBcc

.HTMLBody = sBody

.Attachments.Add sTempFilePath & sTempFileName

'.Attachments.Add ActiveWorkbook.FullName

'.Attachments.Add ("C:\test.txt")

.Display

'.Send

End With

 

'Delete the file

Kill sTempFilePath & sTempFileName

 

ErrorHandle:

If Err.Description <> "" Then MsgBox Err.Description

 

Set objMail_Object = Nothing

Set objMail_Single = Nothing

 

With Application

.ScreenUpdating = True

.EnableEvents = True

End With

 

End Sub

 

Categories: None

Post a Comment

Oops!

Oops, you forgot something.

Oops!

The words you entered did not match the given text. Please try again.

Already a member? Sign In

0 Comments