MyTetra Share
Делитесь знаниями!
Отправить письмо из Outlook
Время создания: 16.03.2019 23:43
Раздел: !Закладки - VBA - Access - leadersoft.ru
Запись: xintrea/mytetra_db_adgaver_new/master/base/15313734011aq6tadvhd/text.html на raw.githubusercontent.com

Отправить письмо из Outlook

01. Этот пример (1) позволяет вам отправить электронное сообщение из Access через Outlook. Для работы программы в новых файлах создайте ссылку на Outlook в VBA: C:\Program Files\Microsoft Office\OFFICE11\MSOUTL.OLB


'==============================================================
'  Назначение
'    "Послать почту из базы данных"
Private Sub butExecute_Click()
Dim app As Outlook.Application  'Приложение программы
Dim dbs As Database 'База данных
Dim rst As Recordset 'Источник email
Dim As Integer 'Счетчик
Dim itm As MailItem 'Почтовое сообщение
Dim myFile As String 'Присоединяемый файл

    
On Error GoTo 999
    
Set dbs = CurrentDb 'Выбор базы данных
    Me.Refresh 
'Сохраняем данные
    myFile = Application.CurrentProject.Path & 
"\" & Me.Attachment
    myFile = Dir(myFile)
    
'Открываем таблицу c почтовыми адресами
    
Set rst = dbs.OpenRecordset("SELECT * FROM [Пример 01email] WHERE ([Вкл]=True);")
    
If rst.RecordCount <> 0 Then 'Проверяем записи
        rst.MoveLast 
'Заполняем запрос
        rst.MoveFirst 
'Первая запись
        
Set app = New Outlook.Application 'Новое сообщение
        
Dim myNamespace, myfolder As MAPIFolder, mynewfolder
        
Set myNamespace = app.GetNamespace("MAPI")
        
Set myfolder = myNamespace.GetDefaultFolder(olFolderInbox)
        
'Set myfolder = _
        '    app.ActiveExplorer.CurrentFolder.Folders

        
Set mynewfolder = myfolder.Folders.Add("My Contacts")
        
        
Set itm = app.CreateItem(olMailItem) 'Добавляем письмо
        itm.Subject = Me.Subject  
'Тема письма
        itm.Body = Me.Body 
'Текст письма
        
If myFile <> "" Then itm.Attachments.Add myFile 'Прикрепляем файл
        
For i = 0 To rst.RecordCount - 1 'Просматриваем адреса
            
If rst!Вкл = True Then _
                itm.Recipients.Add rst!Email 
'Добавляем новый адрес
            rst.MoveNext 
'Следующий адрес
        
Next
        itm.Send 
'Отсылаем письмо
        app.Quit 
'Закрываем Outlook
        MsgBox 
"Письмо успешно отправлено!", vbExclamation, "Почта"
    
End If
    rst.Close 
'Закрываем запрос
    
Exit Sub
999:
    MsgBox Err.Description  
'Ошибка
    Err.Clear
    app.Quit
End Sub

Так же в этом разделе:
 
MyTetra Share v.0.59
Яндекс индекс цитирования