'For Early Binding, enable Tools > References > Microsoft CDO for Windows 2000 Library
Option Explicit
Sub SendEmailUsingGmail()
Dim NewMail As Object
Dim mailConfig As Object
Dim subj As String
Dim fso As Object
Dim fields As Variant
Dim msConfigURL As String
Dim rng As Range
Workbooks.Open "C:\Users\allso\Desktop\new vba projects\new project subham brother\DPR NOV 2020.xlsb"
subj = Workbooks("DPR NOV 2020.xlsb").sheets("ZONE").Range("H1").Value
Workbooks("DPR NOV 2020.xlsb").Close SaveChanges:=True
Set rng = Nothing
On Error Resume Next
' Set rng = Selection.SpecialCells(xlCellTypeVisible)
On Error GoTo Err:
'late binding
Set NewMail = CreateObject("CDO.Message")
Set mailConfig = CreateObject("CDO.Configuration")
Const cdoRefTypeId = 0
Set fso = CreateObject("Scripting.FileSystemObject")
' load all default configurations
mailConfig.Load -1
Set fields = mailConfig.fields
'Set All Email Properties
With NewMail
.AutoGenerateTextBody = False
.Sender = "allsourav2@gmail.com"
.From = "Sourav Bhattacharya"
.To = "" 'mail address
.CC = ""
.BCC = ""
.Subject = subj
.BodyPart.ContentTransferEncoding = "quoted-printable"
.BodyPart.Charset = "utf-8"
'.Textbody = "Let me know if you have questions about the attached spreadsheet!"
' Adding images as inline attachments with Content IDs which is used with image sources. e.g. <img src="cid:image1" .. >
.AddRelatedBodyPart fso.GetAbsolutePathName("C:\Users\allso\Desktop\new vba projects\temp1.jpg"), "temp1", cdoRefTypeId
.AddRelatedBodyPart fso.GetAbsolutePathName("C:\Users\allso\Desktop\new vba projects\temp2.jpg"), "temp2", cdoRefTypeId
'.Addattachment "C:\Users\allso\Desktop\new vba projects\temp.jpg"
'.HTMLBody = .Textbody & "<html><p>CPS Daily progress Report of Nov 2020</p>" & _
"<img src=""cid:temp.jpg"" height='600' width='900'>"
'append html body from file
.HTMLBody = fso.OpenTextFile("C:\Users\allso\Desktop\new vba projects\temp.html").ReadAll
End With
msConfigURL = "http://schemas.microsoft.com/cdo/configuration"
With fields
.Item(msConfigURL & "/smtpusessl") = True 'Enable SSL Authentication
.Item(msConfigURL & "/smtpauthenticate") = 1 'SMTP authentication Enabled
.Item(msConfigURL & "/smtpserver") = "smtp.gmail.com" 'Set the SMTP server details
.Item(msConfigURL & "/smtpserverport") = 465 'Set the SMTP port Details
.Item(msConfigURL & "/sendusing") = 2 'Send using default setting
.Item(msConfigURL & "/sendusername") = "" 'Your gmail address
.Item(msConfigURL & "/sendpassword") = "" 'Your password or App Password
.Update 'Update the configuration fields
End With
NewMail.Configuration = mailConfig
NewMail.Send
MsgBox "Your email has been sent", vbInformation
Exit_Err:
'Release object memory
Set NewMail = Nothing
Set mailConfig = Nothing
Set fso = Nothing
End
Err:
Select Case Err.Number
Case -2147220973 'Could be because of Internet Connection
MsgBox "Check your internet connection." & vbNewLine & Err.Number & ": " & Err.Description
Case -2147220975 'Incorrect credentials User ID or password
MsgBox "Check your login credentials and try again." & vbNewLine & Err.Number & ": " & Err.Description
Case Else 'Report other errors
MsgBox "Error encountered while sending email." & vbNewLine & Err.Number & ": " & Err.Description
End Select
Resume Exit_Err
End Sub
temp.html file contains
<img src="cid:temp1" alt="SpaceImage" title="first image" style="display: block" width="900" height="550" />
<img src="cid:temp2" alt="HostImage" title="second image" style="display: block" width="900" height="1000" />
No comments:
Post a Comment