Condition based mass mailing using outlook and vba

 Option Explicit

Sub Send_Email_with_Signature()

Dim Outlook_App As Object
Dim msg As Object
Dim sign As String
Dim i As Integer
Set Outlook_App = CreateObject("Outlook.Application")
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Data")
 
For i = 3 To sh.Range("B" & Application.Rows.Count).End(xlUp).Row

If sh.Range("A" & i).Value = "" Then  ''Check Skip
    
    Set msg = Outlook_App.CreateItem(0)
    
    With msg
       ' .display
    End With
    
    sign = msg.htmlbody
    
    With msg
        .To = sh.Range("C" & i).Value
        .Subject = "Payment Reminder"
        .htmlbody = "Dear <b>" & sh.Range("B" & i).Value & "</b>,<br><br><p>Please pay your bill for below given service(s)- </p>" & _
        "<ul>" & _
        IIf(sh.Range("D" & i).Value <> "", "<li><b style='color:DodgerBlue'><u>" & sh.Range("D2").Value & ":</u></b>  " & Format(sh.Range("D" & i).Value, "0.0") & " is pending.</li>", "") & _
        IIf(sh.Range("E" & i).Value <> "", "<li><b style='color:Tomato;'><u>" & sh.Range("E2").Value & ":</u></b>  " & Format(sh.Range("E" & i).Value, "0.0") & " is pending.</li>", "") & _
        IIf(sh.Range("F" & i).Value <> "", "<li><b style='color:green;'><u>" & sh.Range("F2").Value & ":</u></b>  " & Format(sh.Range("F" & i).Value, "0.0") & " is pending.</li>", "") & _
        IIf(sh.Range("G" & i).Value <> "", "<li><b style='color:Orange;'><u>" & sh.Range("G2").Value & ":</u></b>  " & Format(sh.Range("G" & i).Value, "0.0") & " is pending.</li>", "") & _
        IIf(sh.Range("H" & i).Value <> "", "<li><b style='color:Blue;'><u>" & sh.Range("H2").Value & ":</u></b>  " & Format(sh.Range("H" & i).Value, "0.0") & " is pending.</li>", "") & _
        "</ul>" & _
        sign
    
        If sh.Range("H1").Value = 1 Then  ''' check option button value
            .send
        Else
            .display
        End If
    End With
    
    Set msg = Nothing

End If

Next i


Set Outlook_App = Nothing

If sh.Range("H1").Value = 1 Then MsgBox "Done"

End Sub

Source:https://www.youtube.com/watch?v=A6tggcOV6ts

Send email in outlook with excel sheet snapshot using VBA

 Option Explicit

Sub Send_Email_With_snapshot()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Sheet1")

Dim lr As Integer
lr = sh.Range("A" & Application.Rows.Count).End(xlUp).Row

sh.Range("A1:H" & lr).Select

With Selection.Parent.MailEnvelope.Item
    .to = sh.Range("L6").Value
    .cc = sh.Range("L7").Value
    .Subject = sh.Range("L8").Value
    .attachments.Add "C:\Users\allso\Desktop\new vba projects\arnab first class.xlsx"
    .send
End With

MsgBox "Done"


End Sub

 

 

 

Source:https://www.pk-anexcelexpert.com/send-email-with-snapshot/

 Source:https://www.youtube.com/watch?v=aD-lo81I5C4

 

Send gmail with embedded picture in mail body using VBA

 '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" />

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

Convert excel range to a picture using VBA

 Option Explicit


Sub Exportrangetopicture(oWs As Worksheet, rng As String, num As Integer)
'Hides alerts
 Application.DisplayAlerts = False
 'Dim oWs As Worksheet
 Dim oRng As range
 Dim oChrtO As ChartObject
 Dim lWidth As Long, lHeight As Long

 'Set oWs = sheets("AREA")
 
 Set oRng = oWs.range(rng).CurrentRegion

 oRng.CopyPicture xlScreen, xlPicture
 lWidth = oRng.Width
 lHeight = oRng.Height

 Set oChrtO = oWs.ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight)

 oChrtO.Activate
 With oChrtO.Chart
  .Paste
  .Export Filename:="C:\Users\allso\Desktop\new vba projects\temp" & num & ".jpg", Filtername:="JPG"
 End With

 oChrtO.Delete

 'shows alerts
    Application.DisplayAlerts = True
End Sub

Sub callingfunc()
Workbooks.Open "C:\Users\allso\Desktop\new vba projects\new project subham brother\DPR NOV 2020.xlsb"
Dim ws As Worksheet
Set ws = Workbooks("DPR NOV 2020.xlsb").sheets("AREA")
Call Exportrangetopicture(ws, "J2", 1)
Set ws = Nothing
Set ws = Workbooks("DPR NOV 2020.xlsb").sheets("Zone")
Call Exportrangetopicture(ws, "H1", 2)
Workbooks("DPR NOV 2020.xlsb").Close SaveChanges:=True
End Sub