Sub Send_Mail()
    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String

    Application.ScreenUpdating = False
    On Error Resume Next

    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    objOutlookApp.Session.Logon
    Set objMail = objOutlookApp.CreateItem(0)
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
    
    sTo = Range("D3")
    sSubject = "Привет"
    sBody = Range("F3").Value
    sAttachment = Range("F3").Value
    
        With objMail
        .To = sTo
        .CC = ""
        .BCC = ""
        .Subject = sSubject
        .Body = sBody & String(4, vbCrLf)
        .HTMLBody = sBody
        .Attachments.Add sAttachment
        .Display
    End With

    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub