Just random mumbling: December 2020

Tuesday, December 8, 2020

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

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

Change the range of source data of a pivot table programmatically using VBA

Option Explicit

Sub Copy_Paste_To_DPR_Pivot()
'Find the last used row in both sheets and copy and paste data below existing data.

Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lcopyLastRow As Long
Dim lDestLastRow As Long

'Open method requires full file path to be referenced.

Workbooks.Open "C:\Users\allso\Desktop\new vba projects\new project subham brother\DPR NOV 2020.xlsb"

'Set variables for copy and destination sheets
Set wsCopy = Workbooks("New Raw File Dual@.xlsb").Worksheets("NEW")
Set wsDest = Workbooks("DPR NOV 2020.xlsb").Worksheets("RAW FILE")


'clear content on the destination sheet except header

wsDest.Rows("2:" & wsDest.Rows.Count).ClearContents

   '1. Find last used row in the copy range based on data in column A
lcopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row

'Copy range to clipboard
wsCopy.range("A2:P" & lcopyLastRow).Copy

'PasteSpecial to paste values, formulas, formats, etc.
wsDest.range("A2").PasteSpecial Paste:=xlPasteValues

    'arrange and refresh the pivot table

    'Set variables for copy and destination sheets
Set wsCopy = Workbooks("DPR NOV 2020.xlsb").Worksheets("RAW FILE")
Set wsDest = Workbooks("DPR NOV 2020.xlsb").Worksheets("PIVOT")
lcopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row
Dim datarange As String

   datarange = wsCopy.Name & "!" & range("A1:P" & lcopyLastRow).Address(ReferenceStyle:=xlR1C1)


        wsDest.PivotTables("PivotTable1").ChangePivotCache ActiveWorkbook. _
        PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        datarange)

'Close the workbook

Workbooks("DPR NOV 2020.xlsb").Close SaveChanges:=True

End Sub