sub отправить_почту()

sUsername = "test@gmail.com" ' Учетная запись на сервере
sPass = "YCxAHX71"    ' Пароль к почтовому аккаунту
sSubject = "тема письма"
sTo = "test1@gmail.com" 
sFrom = "test@gmail.com"  
sBody = "Здравствуйте"
sAttachment = ""
BCC = "test2@gmail.com"  
SMTPServer = "smtp.gmail.com"
Call отправка_email(SMTPServer, sUsername, sPass, sTo, sFrom, sSubject, sBody, vFolders, BCC) 
end sub 


Sub отправка_email(SMTPServer, sUsername, sPass, sTo, sFrom, sSubject, sBody, sAttachment, Optional BCC)'отправляем почту
'======================
If sSubject = "" Then Exit Sub
If sTo = "" Then Exit Sub


sTo = WorksheetFunction.Trim(sTo)


    Const CDO_Cnf = "http://schemas.microsoft.com/cdo/configuration/"
    Dim oCDOCnf As Object, oCDOMsg As Object
'    Dim SMTPserver As String, sUsername As String, sPass As String, sMsg As String
'    Dim sTo As String, sFrom As String, sSubject As String, sBody As String, sAttachment As String
'    On Error Resume Next
    'sFrom - как правило совпадает с sUsername
    If Len(SMTPServer) = 0 Then MsgBox "Не указан SMTP сервер", vbInformation, "www.Excel-VBA.ru": Exit Sub
    If Len(sUsername) = 0 Then MsgBox "Не указана учетная запись", vbInformation, "www.Excel-VBA.ru": Exit Sub
    If Len(sPass) = 0 Then MsgBox "Не указан пароль", vbInformation, "www.Excel-VBA.ru": Exit Sub


    'Проверка наличия файла по указанному пути
'    If Dir(sAttachment, vbDirectory) = "" Then sAttachment = ""
    'Назначаем конфигурацию CDO
    Set oCDOCnf = CreateObject("CDO.Configuration")
    With oCDOCnf.Fields
        .Item(CDO_Cnf & "sendusing") = 2
        .Item(CDO_Cnf & "smtpauthenticate") = 1
        .Item(CDO_Cnf & "smtpserver") = SMTPServer
        'если необходимо указать SSL
        .Item(CDO_Cnf & "smtpserverport") = 465 'для Яндекса и Gmail 465
        .Item(CDO_Cnf & "smtpusessl") = True
        '=====================================
        .Item(CDO_Cnf & "sendusername") = sUsername
        .Item(CDO_Cnf & "sendpassword") = sPass
        .Update
    End With
    'Создаем сообщение
    Set oCDOMsg = CreateObject("CDO.Message")
    With oCDOMsg
        Set .Configuration = oCDOCnf
        .BodyPart.Charset = "Windows-1251"
        .From = sFrom
        .To = sTo
        .BCC = BCC
        .Subject = sSubject
        .TextBody = sBody
        If IsArray(sAttachment) Then
        
            For n = 0 To UBound(sAttachment)
            .AddAttachment sAttachment(n)
            Next
        ElseIf Len(sAttachment) > 0 Then
        .AddAttachment sAttachment
        End If


'        If Len(sAttachment) > 0 Then .AddAttachment sAttachment
'On Error Resume Next
        .Send
    End With
    
    Debug.Print Err.Number
'    MsgBox Err.Number
'    Select Case Err.Number
'    Case -2147220973: sMsg = "Нет доступа к Интернет"
'    Case -2147220975: sMsg = "Отказ сервера SMTP"
'    Case 0: sMsg = "Письмо отправлено"
'    Case Else: sMsg = "Ошибка номер: " & Err.Number & vbNewLine & "Описание ошибки: " & Err.Description
'    End Select
    On Error GoTo 0
'    MsgBox sMsg, vbInformation
    Set oCDOMsg = Nothing: Set oCDOCnf = Nothing
    
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.DisplayAlerts = True
ActiveSheet.EnableCalculation = True
Application.ScreenUpdating = True
   
End Sub

Function Extract_Value_ADO(sPath As String, sFileName As String, sShName_источник As String, sShName_цель As String, sRng As String)    Dim objADO_Con As Object, objRS As Object
    Dim sFullFileName As String, sADORng As String

    sFullFileName = sPath & sFileName
    With CreateObject("ADODB.Connection")
        'подключаемся к файлу
        .Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};ReadOnly=1;DBQ=" & sFullFileName & ";"
        'извлекаем записи из указанного диапазона в objRS
        Set objRS = .Execute("select * FROM [" & sShName_источник & "$" & sADORng & "]")
        'выгружаем извлеченные данные на активный лист, начиная с ячейки А1
        ActiveWorkbook.Sheets(sShName_цель).Cells(1, 1).CopyFromRecordset objRS
        
'        Extract_Value_ADO = objRS.Fields(0).Value
    End With
    Set objRS = Nothing
End Function