VBA, MS Access MS Access в примерах

Отправка E-Mail через CDO.Message (с вложением)

Private Sub Email_Click() 'Нажатие на кнопку
'Сохраняем отчёт "rptTest" в папку на HDD ("D:\Temp\MyReport.pdf")
    DoCmd.OutputTo acOutputReport, "rptTest", acFormatPDF, "D:\Temp\MyReport.pdf"
    DoEvents
'Отсылаем - Кому - Тема - Текст - Вложение
    SendEmail "906750683@gmail.com", "Test 01", "Проверка кода ...", "D:\Temp\MyReport.pdf"
    DoEvents
'Удаляем временный файл ...
    Kill "D:\Temp\MyReport.pdf"

End Sub


Public Function SendEmail(sTo$, sSubject$, sTextBody$, Optional sAttachment = "")
'Отправка почты через CDO.Message (тут на smtp.yandex.ru)
'--------------------------------------------------------------------------
'Доп инфо: http://www.askit.ru/custom/vba_office/m13/13_08_cdo_vba.htm
'--------------------------------------------------------------------------
Dim msg As Object
Dim sConfig As String

On Error GoTo SendEmail_Err

    Set msg = CreateObject("CDO.Message")

    msg.BodyPart.Charset = "windows-1251"
    sConfig = "http://schemas.microsoft.com/cdo/configuration/"
    With msg
        .To = sTo ' Кому ...
        
        .From = "Имя_Пользователя@yandex.ru" '!!! - От кого !
        
        .Subject = sSubject ' тема сообщения
        .TextBody = sTextBody '"Бла Бла Бла, провнрка связи" = Cодержание сообщения
        If Dir(sAttachment) <> "" Then
            .AddAttachment (sAttachment)  'Вложение
        End If
        With .Configuration.Fields
            .Item(sConfig & "sendusing") = 2
            .Item(sConfig & "smtpserver") = "smtp.yandex.ru" 'SMTP Сервер
            .Item(sConfig & "smtpauthenticate") = 1  'SMTP Требует аутификацию = 1 (нет = 0)
            .Item(sConfig & "smtpserverport") = 465  'SMTP Порт номер
            .Item(sConfig & "smtpusessl") = True     'SMTP Использовать SSL
            
            '!!!
            .Item(sConfig & "sendusername") = "Имя_Пользователя@yandex.ru" 'Адрес отправителя
            
            '!!!
            .Item(sConfig & "sendpassword") = "XXXXXX"    'Пароль электронного ящика отправителя
            
            .Item(sConfig & "smtpconnectiontimeout") = 30 'Сколько ждать ответа сервера в секундах
            .Update
        End With
        .send 'Собственно отправка сабжа ...
    End With
     

SendEmail_End:
    On Error Resume Next
    Set msg = Nothing
    Exit Function

SendEmail_Err:
    MsgBox "Error: " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in Function: SendEmail in module: mod00Test", vbCritical, "Error in Application"
    Err.Clear
    Resume SendEmail_End
End Function



Назад ToTop
L.E. 06.02.2019
Рейтинг@Mail.ru