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 

Do
Range("a2").Activate
bookname = ActiveCell.Offset(r, c).Range("A1")

On Error GoTo Label

Workbooks.Open Filename:= _
        bookadr & "/" & bookname
Workbooks(bookname).Close

c = c + 1
ActiveCell.Offset(r, c).Range("A1").Select
ActiveCell = "+"
c = c - 1

GoTo Labey

Label:
c = c + 1
ActiveCell.Offset(r, c).Range("A1").Select
ActiveCell = "-"
c = c - 1

Labey:
r = r + 1
i = i + 1
Loop Until i = 15