Страницы: 1
RSS
Сохранение файла и рассылка писем при помощи VBA.
 
Добрый день.
Я новичок и совсем не шарю, помогите найти ошибки в коде, он не запускается и нужны еще кое какие дополнения:
1. В коде мне нужно, чтобы после некого действия которое запускается кнопкой (Макрос1 был написан только как пример такого действия), выскакивало окошко выбора для отправки сообщения "да" "нет", а после происходила рассылка листа1(в котором реализовывалось действие Макроса1), по списку почтовых ящиков листа2.
Дополнения к коду: чтобы я не указывала каждый раз ссылки на вложения в списке почтовых ящиков т.к. файл будет сохраняться каждый раз в разную папку по датам, нужно чтобы макрос предлагал "сохранить как", и из того же расположения данных брал вложение для писем сам.

2. В будущем мне нужно будет делать множество файлов вложений в папке с датой и каждое вложение (например с ФИО сотрудника получателя) отправлять на отдельный адрес, собираюсь создать специальный справочник почтовых адресов и названий файлов вложений, чтобы на каждый адрес высылался строго конкретный файл. Если будут подсказки, ссылки, идеи и по пункту 2, буду премного благодарна. Спасибо заранее!

Код
Sub Макрос1()
'операция заполняет столбик значениями от 1 до 5 на листе1, взята только как пример. 
For i = 1 To 5
Cells(i, 2) = i
Next i

End Sub

Sub Макрос2()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim Ansr As String
'наверное где то здесь должен быть код "сохранить как", который будет сохранять лист1 в папку которая выбирается вручную.

Ansr = MsgBox("Отправлять данные автоматически?", vbQuestion + vbYesNo + vbExclamation, "Почта")
If Ansr = vbYes Then
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
For Each cell In Columns("D").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "*******@****.**" And _
Application.WorksheetFunction.CountA(cell) > 0 Then
Set OutMail = OutApp.CreateItem(0)
On Error GoTo cleanup
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = Range("E2").Value
.Body = Range("F2").Value
'здесь будет мой почтовый ящик
.BCC = "*******@****.**" 
.Attachments.Add Range("H2").Value
.Send
Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Изменено: Spyse - 07.10.2016 16:16:48
 
Код
Sub Макрос2()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim Ansr As String
'наверное где то здесь должен быть код "сохранить как", который будет сохранять лист1 в папку которая выбирается вручную.
 
Ansr = MsgBox("Отправлять данные автоматически?", vbQuestion + vbYesNo + vbExclamation, "Почта")
If Ansr = vbYes Then
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
For i = 2 to 5 ' ------------------------------ здесь ваши строки с адресами
 
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Range("D" & i).Value
.Subject = Range("E" & i).Value
.Body = Range("F" & i).Value
'здесь будет мой почтовый ящик
.BCC = "*******@****.**"
if Range("H" & i).Value <>"" Then .Attachments.Add Range("H" & i).Value
.Send
Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next i
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub


пробуйте так.
предполагает наличие адресов и других соответствующих полей в строках 2:5.
в случае необходимости можно добавить автоопределение количества строк и всякие защиты от дурака)
проверить у себя не могу, так как аутлуком не пользуюсь уже давно)

п.с. а код по сохранению листа в отдельную книгу - это уже другая тема и отдельный макрос - их лучше в кучу не лепить.
Изменено: Dima S - 08.10.2016 12:20:29
 
Спасибо большое, очень интересный пример, но только почему то редактор выдает ошибку sub or function not defined, выделяет при этом команду Display, когда Display удаляю пишет ошибку End If without block If. Не понимаю с чем все это связано.
А что такое защита от дурака?
 
Я поняла в чем дело, ошибки исправила, но макрос только открывает msgbox, ни какие письма не отправляет.
Исправления тут:
Код
If Range("H" & i).Value <> "" Then
         .Attachments.Add Range("H" & i).Value
         End If
      .Send
      .Display
      End With
   On Error GoTo 0
   Set OutMail = Nothing
   Next i
   Set OutApp = Nothing
   End If
Application.ScreenUpdating = True
End Sub 

Обозначения нужных столбцов проверила, они совпадают с кодом.
Макрос не дает команду перехода в Аутлук как мне кажется.
Может быть нужно еще что то указать здесь?
OutApp.Session.Logon  
Изменено: Spyse - 10.10.2016 21:56:31
Страницы: 1
Наверх