Tuesday, December 8, 2020

Send gmail using VBA with attachment

 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



No comments:

Post a Comment