Помогите, пожалуйста, пытаюсь упростить процесс заполнения и одобрения форм-опросников. Есть список полей с вопросами, ответы на которые я добавила в связанные списки и т.п. Все работает Теперь осталось всю эту красоту (таблицу по диапазону) одним нажатие кнопки отправить в outlook для дальнейшей отправки. Т.е. Необходимо сформировать тело письма, в которое надо вставить определенный Range таблицы (10x10 ячеек) и добавить текст-обрамление (фиксированный: обращение, подпись и т.п.). Нашла макрос в интернете, но он почему-то никак не работает (нажимаю на кнопку и ничего!). Вот как блонди сижу и думаю, что делать?
Код
Sub CommandButton1_Click()
Dim mailApp As Outlook.Application
Dim dfg As Object
'поиск окна Microsoft Outlook
lngRetVal = FindWindowByClass("rctrl_renwnd32", 0&;)
If lngRetVal <> 0 Then
Set mailApp = GetObject(, "Outlook.Application")
Else
Set mailApp = CreateObject("Outlook.Application")
End If
Set objMail = mailApp.CreateItem(olMailItem)
Set dfg = objMail.Recipients.Add("test@test.com")
dfg.Type = olTo
With objMail
.Importance = olImportanceHigh
.Subject = "Your Subject"
.BodyFormat = olFormatHTML 'формат HTML
.HTMLBody = SheetToHTML(ThisWorkbook.Worksheets("tasks"))
End With
'Предварительный просмотр письма
'objMail.Display
'Отправка письма
objMail.Send
Set objMail = Nothing
Set mailApp = Nothing
End Sub
Будут доказательства,получите макрос А пока скопируйте в модуль к вашему макросу с источника две функции
Код
Public Function SheetToHTML(sh As Worksheet)
.........................................
................................................
End Function
Declare Function FindWindowByClass Lib "user32" _ Alias "FindWindowA" (ByVal lpClassName As String, _ ByVal lpWindowName As Long) As Long
Страшно спросить, какие нужны доказательства;) но в VBA я реально плохо разбираюсь, знаю азы, которым учат в университете. Я решила прогнать макрос по коду и он мне выдает ошибку на самом начале, когда задается MailApp как Outlook.Application.
Годится.Шутку не поняли. Ваш код будет такой,за исключением конвертации в HTML
Код
Dim mailApp As Object
Set mailApp = CreateObject("Outlook.Application")
With mailApp.CreateItem(0)
.To = "test@test.com"
.Subject = "Your Subject"
.BodyFormat = 2
.HTMLBody = SheetToHTML(ThisWorkbook.Worksheets("tasks"))
.Send
End With
Set mailApp = Nothing
Iv_Juliette пишет: Ошибка во второй строчке - "ActiveX component can't create an object"
Значит у вас не установлен аутлук. 2 варианта. 1. Отправка через командную строку почтовой программы,если она у вас есть. 2.отправка средствами винды при помощи CDO
Public Function SheetToHTML(sh As Worksheet)
Dim TempFile As String
Dim fso As Object
Dim ts As Object
sh.Copy
TempFile = sh.Parent.Path & "\TempHtml.htm"
With ActiveWorkbook.PublishObjects.Add(xlSourceRange, _
TempFile, "Sheet1", "A1:F30", xlHtmlStatic, "333_8568" _
, "")
.Publish (True)
.AutoRepublish = False
End With
ActiveWorkbook.Close False
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
SheetToHTML = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
Kill TempFile
End Function
Остался вопрос текста-обрамления и несколько моментов редактирования. - внести фиксированный текст письма + подпись определенного формата? - таблица в тело письма вставляется по центру, как сделать по левому краю?
Я воспользовалась кодом от мага и чародея Doober За что ему ОГРОМНЕЙШЕЕ СПАСИБО!!! Он просто спас мой последний выходной
Текст-обрамление решила вставить в таблицу и расширить диапазон вставки в тело письма, а в excelнике просто их "зашить" от лишних глаз...работает)) Но всё же, как вставку сделать по левому краю?
Iv_Juliette пишет: подбираю методом "тыка"... кручу-верчу функцию Align
Теперь работает правильно
Скрытый текст
Код
Public Function SheetToHTML(sh As Worksheet)
Dim TempFile As String
Dim fso As Object
Dim ts As Object
sh.Copy
TempFile = sh.Parent.Path & "\TempHtml.htm"
With ActiveWorkbook.PublishObjects.Add(xlSourceRange, _
TempFile, Sh.name, "A1:F13", xlHtmlStatic)
.Publish (True)
.AutoRepublish = False
End With
ActiveWorkbook.Close False
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
SheetToHTML = ts.ReadAll
SheetToHTML = Replace(SheetToHTML, "align=center", "align=left")
ts.Close
Set ts = Nothing
Set fso = Nothing
Kill TempFile 'сделать экспорт таблицы по средством временного файла, а затем его удалить
End Function
добрый день ! очень прошу помощи есть таблица короткий пример во вложении. нужно чтобы формировал письма адресат берется из столбца ФИО а вот в теле данные из столбцов "дело1 дата дело1 результат " из соответствующих ФИО строк то есть у васи пупкина будет выглядеть так ...... .To = "ВасяПупкин@mail.ru" .Body = 123 01.04.2015 + 123 03.04.2015 - .Display
вот как в тело вставить данные я не понимаю ( помогите пожалуйста
Как-то так это выглядит в Excel (c забором темы, адреса, сообщения с листа Excel - "Данные" ) Можно сделать перебор по строкам "Х" , с рассылкой разных писем (в данном случае по 100 строкам). Номера столбцов в Cells() поставте свои.
Код
...
For x = 1 To 100 Step 1
Set OutlookApp = CreateObject("Outlook.Application")
Set SM = OutlookApp.CreateItem(olMailItem)
адрес = Sheets("Данные").Cells(x, 17)
тема = Sheets("Данные").Cells(x, 18)
сообщение = Sheets("Данные").Cells(x, 19)
SM.To = адрес
SM.Subject = тема
сообщение2 = Replace(сообщение, "vbNewLine", "<br>")
SM.HTMLBody = "<FONT Size = 2> " & сообщение2 & " </FONT>"
SM.send
Next x
...
Уважаемые ГУРУ! Помогите, пожалуйста. Я не могу никак совладать с прикреплением файла, а также таблицы в тело письма. Пример файла во вложении.
С вложением - может ли быть проблема в том, что путь к файлу формируется формулой? Не могу никак понять, как прописать код, чтобы таблица с листа (имя листа = имя менеджера из таблицы в email) вставлялась в тело письма я уже несколько макросов разных перепробовала, не могу я их под свой файл подпилить.
Плиииз ХЕЛП!
Вот имеющийся код, который прекрасно создает и отправляет письма, однако не вставляет таблицу и файл. А еще вопрос, как прописать определенный шрифт и цвет тексту в письме?
Код
Sub CreateMail()
Dim stFileName As String
Dim objOutlook As Object
Dim objMail As Object
Dim rngEntry As Range
Dim rngEntries As Range
Set objOutlook = CreateObject("Outlook.Application")
Set rngEntries = Worksheets("emails").Range("Sales_mail")
For Each rngEntry In rngEntries
stFileName = rngEntry.Offset(0, 2)
If Dir(stFileName) <> "" Then
Set objMail = objOutlook.CreateItem(0)
With objMail
On Error Resume Next
.To = rngEntry.Offset(0, 0).Value
.CC = rngEntry.Offset(0, 3).Value
.Subject = rngEntry.Offset(0, 2).Value
.Body = Range("F1")
.Attachments.Add (rngEntry.Offset(0, 4).Value)
.Send '.Display or .save
End With
Else
MsgBox "No data for" & " " & rngEntry.Offset(0, -1).Value
End If
Next rngEntry
Set objOutlook = Nothing
Set objMail = Nothing
Set rngEntry = Nothing
Set rngEntries = Nothing
End Sub
Мария -, Я вам скинул ссылку с сайта Дмитрия Щербакова, скачайте файл, и попробуйте запустить макрос, посмотрите так ли вам нужно, ну а далее по аналогии примените к своему файлу.