Option Explicit
Sub SendEmailUsingGmail()
Dim NewMail As Object
Dim mailConfig As Object
Dim fields As Variant
Dim msConfigURL As String
Dim rng As Range
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")
' load all default configurations
mailConfig.Load -1
Set fields = mailConfig.fields
'Set All Email Properties
With NewMail
.Sender = "" 'mail address
.From = "Sourav Bhattacharya"
.To = "" 'mail address
.CC = ""
.BCC = ""
.Subject = "Demo Spreadsheet Attached"
.Textbody = "Let me know if you have questions about the attached spreadsheet!"
.Addattachment "C:\Users\allso\Desktop\new vba projects\temp.jpg"
.HTMLBody = .Textbody
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
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
Tuesday, December 8, 2020
Send gmail using VBA with attachment
Subscribe to:
Post Comments (Atom)
No comments:
Post a Comment