Приветствую старожил и гуру мира Excel.
Ломаю голову над задачкой по макросу в excel для подготовки рассылки- был подготовлен годный рабочий макрос, после пары бессонных ночей и изучения большого кол-ва материалов, в том числе на этом чудесном форуме= выкладываю в помощь форумчанам (крови и усилий этот мозговой штурм из меня испил достаточно):
Скрытый текст |
|---|
| Код |
|---|
Sub Send_Mail_SAV_Mass() Dim objOutlookApp As Object, objMail As Object Dim lr As Long, lLastR As Long
Application.ScreenUpdating = False
On Error Resume Next
Set objOutlookApp = CreateObject("Outlook.Application")
If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
objOutlookApp.Session.Logon
lLastR = Cells(Rows.Count, 1).End(xlUp).Row 'определяем последнюю заполненную ячейку в столбце А
'цикл от второй строки(можно задать и от первой если надо, но не советую)
For lr = 2 To lLastR
Set objMail = objOutlookApp.CreateItem(0) 'создаем SAV-новое сообщение
'создаем сообщение иначе Бабайка покарает тебя
With objMail
If Dir(Cells(lr, 4), 16) = "" Then
MsgBox "Файл не найден: " & Cells(lr, 4), vbInformation
End If
.To = Cells(lr, 1) 'сюда мыло
.Subject = Cells(lr, 2) 'тему сюда
.body = Cells(lr, 3) 'текст сюда
.Attachments.Add Cells(lr, 4).Value
.Attachments.Add Cells(lr, 5).Value
.Send 'Все ты во власти СПАМ-бота
End With
Next lr
Set objOutlookApp = Nothing: Set objMail = Nothing
Application.ScreenUpdating = True
End Sub |
|
Макрос рабочий, но не хватает подписей..................новая волна мозгового штурма.....
в результате получился усовершенствованный макрос с подписями:
Скрытый текст |
|---|
| Код |
|---|
Sub Send_Mail_SAVZ_Mass()
Dim objOutlookApp As Object, objMail As Object, objMailSig As Object
Dim lr As Long, lLastR As Long
Application.ScreenUpdating = False
On Error Resume Next
Set objOutlookApp = CreateObject("Outlook.Application")
If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
objOutlookApp.Session.Logon
lLastR = Cells(Rows.Count, 1).End(xlUp).Row 'определяем последнюю заполненную ячейку в столбце А
'цикл от второй строки(можно задать и от первой если надо, но не советую)
For lr = 2 To lLastR
Set objMail = objOutlookApp.CreateItem(0) 'создаем SAV-новое сообщение
'создаем сообщение иначе Бабайка покарает тебя
With objMail
If Dir(Cells(lr, 4), 16) = "" Then
MsgBox "Файл не найден: " & Cells(lr, 4), vbInformation
End If
.To = Cells(lr, 1) 'сюда мыло
.Subject = Cells(lr, 2) 'тему сюда
.body = Cells(lr, 3) 'текст сюда
.Attachments.Add Cells(lr, 4).Value
.Attachments.Add Cells(lr, 5).Value
Set objSigMail = objOutlookApp.CreateItem(0)
objSigMail.Display
objMail.body = objMail.body & objSigMail.body
objSigMail.Delete
.Send 'Все ты во власти СПАМ-бота
End With
Next lr
Set objOutlookApp = Nothing: Set objMail = Nothing
Application.ScreenUpdating = True
End Sub |
|
В результате подпись успешно добавляет и по сути все шикарно, но подпись не форматированная и без картинки.
Поэтому пришлось приложить еще усилий в результате была найдена функция Dick Kusleika, и вот тут мои дорогие собратья не помешал бы совет. может, что не так тут:
| Код |
|---|
Sub Send_PODPIS_FULL_Mail_SAV_Mass() Dim objOutlookApp As Object, objMail As Object
Dim SigString As String, signature As String
Dim lr As Long, lLastR As Long
Application.ScreenUpdating = False
On Error Resume Next
Set objOutlookApp = CreateObject("Outlook.Application")
If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
objOutlookApp.Session.Logon
lLastR = Cells(Rows.Count, 1).End(xlUp).Row 'определяем последнюю заполненную ячейку в столбце А
'цикл от второй строки(начало данных с адресами) до последней ячейки таблицы
For lr = 2 To lLastR
Set objMail = objOutlookApp.CreateItem(0) 'создаем SAV-новое сообщение
SigString = "C:\Documents and Settings\" & Environ("Alena") & _
"\Application Data\Microsoft\Signatures\Pups.htm"
If Dir(SigString) <> "" Then
signature = GetBoiler(SigString)
Else
signature = ""
End If
On Error Resume Next
'создаем сообщение иначе Бабайка покарает тебя
With objMail
If Dir(Cells(lr, 4), 16) = "" Then
MsgBox "Файл не найден: " & Cells(lr, 4), vbInformation
End If
.To = Cells(lr, 1) 'сюда мыло
.Subject = Cells(lr, 2) 'тему сюда
.body = Cells(lr, 3) & signature 'текст сюда
.Attachments.Add Cells(lr, 4).Value
.Attachments.Add Cells(lr, 5).Value
.Send 'Все ты во власти СПАМ-бота
End With
Next lr
Set objOutlookApp = Nothing: Set objMail = Nothing
Application.ScreenUpdating = True
End Sub
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemO bject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function |
полный путь к сигнатуре C:\Users\Alena\AppData\Roaming\Microsoft\Signatures
было бы классно если было бы возможно прикрутить мою одну подпись и больше это все не трогать, только как это сделать мой мозг уже ломается.....
