Generate an Email from Excel

--making body mail

Sub PublishToHtml(path As String, sSheet As String, templateFileName As String, sRange As String)

    Dim newName As String

    Dim codesName As String

    

    newName = path & "\" & templateFileName & ".htm"

    codesName = templateFileName & "_30801"

    

    With ThisWorkbook.PublishObjects.Add(xlSourceRange, newName, sSheet, sRange, xlHtmlStatic, codesName, "")

        .Publish (True)

        .AutoRepublish = False

    End With

End Sub

--check a file exist?

Public Function FileFolderExists(strFullPath As String) As Boolean

'Author       : Ken Puls (www.excelguru.ca)

'Macro Purpose: Check if a file or folder exists

    On Error GoTo EarlyExit

    If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True

    

EarlyExit:

    On Error GoTo 0

End Function

--Refresh All Connection
Sub Refresh_All()
    counter = ActiveWorkbook.Connections.Count
    For I = 1 To counter
        With ActiveWorkbook.Connections(I).ODBCConnection
            .BackgroundQuery = False
            .Refresh
        End With
    Next

End Sub

--Create JPG from sheet
--for this procedure file excel should be visible
Sub CreateJPG(sSheet As String, sRange As String, sSlide As String)
    Dim MyPath As String
    Dim rgExp As Range
    
    MyPath = ThisWorkbook.path & "\"
    Sheets(sSheet).Select
    
    ThisWorkbook.Sheets(sSheet).Visible = True
    
    Set rgExp = Range(sRange)
    rgExp.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    
    With ActiveSheet.ChartObjects.Add(Left:=rgExp.Left, Top:=rgExp.Top, _
                                      Width:=(rgExp.Width - 10), Height:=(rgExp.Height - 5))
        .Name = "ChartTempEXPORT"
        .Activate
    End With
   
    ActiveChart.Paste
    ActiveSheet.ChartObjects("ChartTempEXPORT").Chart.Export Filename:=MyPath & sSlide, _
                                                             FilterName:="jpg"
    ActiveSheet.ChartObjects("ChartTempEXPORT").Delete

End Sub

--Send Email
--All To,Cc,Bcc should be filled
Sub SendEmail(image1 As String, sSubject As String)
    Dim objmessage
    Set objmessage = CreateObject("CDO.Message")

    Dim xmlDoc As MSXML2.DOMDocument
    
    Set xmlDoc = CreateObject("MSXML2.DOMDocument")
    xmlDoc.async = False
    xmlDoc.validateOnParse = False
    
    xmlDoc.Load (ThisWorkbook.path & "\emailList.xml")
    
    For Each Z In xmlDoc.SelectNodes("//from")
        FromAddress = Z.Text
    Next
    
    For Each a In xmlDoc.SelectNodes("//to")
        For Each O In a.SelectNodes("//mTo")
            ToAddress = ToAddress & ";" & O.Text
        Next
    Next
    
    For Each B In xmlDoc.SelectNodes("//cc")
        For Each P In B.SelectNodes("//mCc")
            CcAddress = CcAddress & ";" & P.Text
        Next
    Next
    
    For Each C In xmlDoc.SelectNodes("//bcc")
        For Each Q In C.SelectNodes("//mBcc")
            BccAddress = BccAddress & ";" & Q.Text
        Next
    Next
    
    With objmessage
        .Subject = sSubject
        .From = FromAddress
        
        .To = ToAddress
        .Cc = CcAddress
        .Bcc = BccAddress
        
        .Configuration.Fields.Item _
        ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Configuration.Fields.Item _
        ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "10.10.10.10"
        .Configuration.Fields.Item _
        ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        objmessage.Configuration.Fields.Update
        
        sText = ""
        
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set ts = fso.OpenTextFile(ThisWorkbook.path & "\body1.htm")
        Do Until ts.AtEndOfStream
            sText = ts.readall
        Loop
        
        sText = sText
        
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set ts = fso.OpenTextFile(ThisWorkbook.path & "\body2.htm")
        Do Until ts.AtEndOfStream
            sText = sText & ts.readall
        Loop

        htmlString = sText

        
        .HTMLBody = htmlString
             
        
        Set objBP = .AddRelatedBodyPart(ThisWorkbook.path & "\" & image1, image1, CdoReferenceTypeName)
        objBP.Fields.Item("urn:schemas:mailheader:Content-ID") = "<" & image1 & ">"
        objBP.Fields.Update
        
        .send
    End With
    Set fso = Nothing
    Set ts = Nothing
    Set objmessage = Nothing
    

End Sub

-- How to Call All?
Private Sub WorkbookOpen()
    If FileFolderExists(ThisWorkbook.path & "\running.txt") Then
        Dim image1 As String
        
        Refresh_All
        
        image1 = "dashboard.jpg"
        CreateJPG "Dashboard", "B4:J37", image1
        PublishToHtml ThisWorkbook.path, "Body", "body1", "$A$2:$T$3"
        PublishToHtml ThisWorkbook.path, "Body", "body2", "$A$4:$T$6"
        
        SendEmail image1, "Abuser Summary Report"
        Kill ThisWorkbook.path & "\" & image1
        Kill ThisWorkbook.path & "\body1.htm"
        Kill ThisWorkbook.path & "\body2.htm"
        Kill ThisWorkbook.path & "\running.txt"
    End If
End Sub

Execute File for an Automate Job VB Script

Dim objXLApp, objXLWb, objXLWs
Dim objFSO, MyFile

Set objFSO = CreateObject("Scripting.FileSystemObject")

strPath = Replace(WScript.ScriptFullName, WScript.ScriptName, "")
'Replace(WScript.ScriptFullName, WScript.ScriptName, "")
strFileExcel = "Dashboard.xlsm"

strFileName = "running.txt"
strFullName = objFSO.BuildPath(strPath, strFileName)

Set MyFile = objFSO.CreateTextFile(strFullName, True)
MyFile.Close

'Sleep for 5 Second
WScript.Sleep(5000)

'open File Excel

Set objXLApp = CreateObject("Excel.Application")
Set objXLWb = objXLApp.Workbooks.Open(strPath & "\" & strFileExcel)
objXLWb.Application.Visible = True
objXLWb.Application.Run "ThisWorkbook.WorkbookOpen"

objXLWb.Save
objXLWb.Close (False)

Set objXLWs = Nothing  
Set objXLWb = Nothing

objXLApp.Quit
Set objXLApp = Nothing