ActiveSheet.Cells(30, 12).Value = NewFile

Function ConvertRngToHTM(rng As Range)
    Dim fso As Object, ts As Object
    Dim sF As String, resHTM As String
    Dim wbTmp As Workbook
 
    sF = Environ("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    rng.Copy
    Set wbTmp = Workbooks.Add(1)
    With wbTmp.Sheets(1)
   
        .Cells(1).PasteSpecial xlPasteColumnWidths
        .Cells(1).PasteSpecial xlPasteValues
        .Cells(1).PasteSpecial xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
        
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
        
    End With
    With wbTmp.PublishObjects.Add( _
         SourceType:=xlSourceRange, filename:=sF, _
         Sheet:=wbTmp.Sheets(1).name, Source:=wbTmp.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sF).OpenAsTextStream(1, -2)
    resHTM = ts.ReadAll
    ts.Close
ConvertRngToHTM = Replace(resHTM, "align=center x:publishsource=", "align=left x:publishsource=")
    wbTmp.Close False
    Kill sF
    Set ts = Nothing: Set fso = Nothing
    Set wbTmp = Nothing
    Set rng = Nothing
    
End Function

 Sub Send_Email()


Dim OutApp As Object
Dim OutMail As Object
Dim c, u As String
Dim name, count As Integer
Dim PlaceY As Range
Dim rDataR As Range
Dim sBody As String

u = Worksheets("settings").Range("b3")

With Application
    .Calculation = xlManual
    .ScreenUpdating = False
    .EnableEvents = False
End With

c = Worksheets("Settings").Range("b3").Value
sBody = Worksheets("Settings").Range("B4").Value


For i = 1 To c


Set OutApp = CreateObject("outlook.application")
Set OutMail = OutApp.CreateItem(0)


name = ActiveWorkbook.Sheets("Settings").Range("c" & (i + 1)).Value


Worksheets("SMART").PivotTables("ÑâîäíàÿÒàáëèöà1").PivotFields("Ëîãèí îïåðàòîðà"). _
        ClearAllFilters
Worksheets("SMART").PivotTables("ÑâîäíàÿÒàáëèöà1").PivotFields("Ëîãèí îïåðàòîðà"). _
        CurrentPage = name
        
        ThisWorkbook.Worksheets("smart").Select
        
Range("A4").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select

     sBody = Replace(sBody, Chr(10), "<br />")
     sBody = Replace(sBody, vbNewLine, "<br />")
     sBody = "<span style=""font-size: 14px; font-family: Arial"">" & sBody & "</span>"

Set rDataR = Selection
sTblBody = ConvertRngToHTM(rDataR)
sBody = Replace(sBody, "{TABLE}", sTblBody)


With OutMail
    .SentOnBehalfOfName = ActiveWorkbook.Sheets("Settings").Range("b1").Value
    .Subject = ActiveWorkbook.Sheets("Settings").Range("b2").Value
    .To = name & "@poctalion.mail"

    .HTMLBody = sBody
    .Display
   
'   .Send
    
    
End With




Set OutApp = Nothing
Set OutMail = Nothing

'Application.Wait Time:=Now + TimeSerial(0, 0, 2)
Next i



With Application 'Turning graphical options back
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With

Worksheets("settings").Activate

End Sub

Function будет в следующем сообщении - сейчас слишком много символов. 

Sub Send_Email()

--------------------------------------------------------

With OutMail
.SentOnBehalfOfName = ActiveWorkbook.Sheets("Settings").Range("b1").Value
.Subject = ActiveWorkbook.Sheets("Settings").Range("b2").Value 'So called (by myself) head of letter.
.To = name & "qweqweqweqweqweqwe.RU" 


.HTMLBody = "<span LANG=EN>" & "Text" 
Call Get_Txt("321123545684") 'Time to create the image as a JPG file
.Attachments.Add TempFilePath & "321123545684.jpg", 0, 0

.HTMLBody = .HTMLBody & "Text"

'Let us combine object 2 with a body of message
.HTMLBody = .HTMLBody & "<BR>" & "<img src='cid:321123545684.jpg'" & "Text"

.Display 

End With


Set OutApp = Nothing
Set OutMail = Nothing

Next i


With Application 'Turning graphical options back
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With



End Sub





Sub Get_Txt(NameFile As String)

Dim PlaceY As Range

ThisWorkbook.Worksheets("smart").Activate 

Set PlaceY = ThisWorkbook.Worksheets("Smart").Range("A4:c20") 
PlaceY.CopyPicture

With ThisWorkbook.Worksheets("SMART").ChartObjects.Add(PlaceY.Left, PlaceY.Top, PlaceY.Width, PlaceY.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & "\" & NameFile & ".jpg", "JPG"
End With

Worksheets("SMART").ChartObjects(Worksheets("SMART").ChartObjects.count).Delete

Set PlaceY = Nothing

End Sub