Excel Macro для создания электронных писем работает только при открытии IDE
Я искал ответ на это в течение нескольких недель, и это сводит меня с ума:
У меня есть макрос, который копирует определенные ячейки в новое письмо в Outlook. Он отлично работает, если среда IDE открыта, но обычно, если она не вставляет содержимое в текущий лист вместо нового сообщения электронной почты. Еще страннее то, что иногда он будет работать, пока среда IDE закрыта, но в 99% случаев она не будет, что делает этот кошмар для диагностики.
Это сводит меня с ума, вы, ребята, моя единственная надежда!
- Отправка с дополнительной учетной записи электронной почты в Outlook
- Вставка таблицы Excel в электронном письме Outlook: он оглядывается назад
- Excel VBA для поиска в почтовых сообщениях Outlook
- Как экспортировать последние три строки писем в папку из Outlook в Excel?
- Автоматические почтовые сообщения Outlook с использованием VBA
Sub EmailReports() Dim rngSubject As Range Dim rngTo As Range Dim rngBody As Range Dim objOutlook As Object Dim objMail As Object Set objOutlook = CreateObject("Outlook.Application") Set objMail = objOutlook.CreateItem(0) xRow = ActiveCell.Row RMName = Sheets("Dashboard").Range("B" & xRow) LastTaskRow = Sheets(RMName).Range("A1") With Target Range("E" & xRow) = Format(Now(), "MM/DD/YYYY") End With Set rngTo = Range("C" & xRow) Set rngSubject = Worksheets("Dashboard").Range("K4") Set rngBody = Worksheets(RMName).Range("D4:E" & LastTaskRow) rngBody.Copy With objMail .To = rngTo .Subject = rngSubject .Display End With SendKeys "^({v})", True Set objOutlook = Nothing Set objMail = Nothing End Sub Я попытался добавить предложение Дмитрия, хотя я не уверен, что добавил его правильно.
Sub EmailReports() Dim rngSubject As Range Dim rngTo As Range Dim rngBody As Range Dim objOutlook As Object Dim objMail As Object Set objOutlook = CreateObject("Outlook.Application") Set objMail = objOutlook.CreateItem(0) xRow = ActiveCell.Row RMName = Sheets("Dashboard").Range("B" & xRow) LastTaskRow = Sheets(RMName).Range("A1") With Target Range("E" & xRow) = Format(Now(), "MM/DD/YYYY") End With Set rngTo = Range("C" & xRow) Set rngSubject = Worksheets("Dashboard").Range("K4") Set rngBody = Worksheets(RMName).Range("D4:E" & LastTaskRow) rngBody.Copy With objMail .To = rngTo .Subject = rngSubject .Display End With Set objHTML = CreateObject("htmlfile") ClipboardText = objHTML.ParentWindow.ClipboardData.GetData("text") objMail.Body = rngBody.Text Set objOutlook = Nothing Set objMail = Nothing End Sub
- Ошибка отправки электронной почты (gmail) через python с вложением excel xlsx
- Как я могу создавать электронные письма только для уникальных адресов из столбца в excel?
- Не удалось получить Excel для создания электронной почты
- Excel: ошибка во время выполнения '-2147319779 (8002801d)':
- Добавить изображение в тело письма и подпись в Outlook через Excel-Vba
- Слияние с полем группового ключа из баз данных Excel или SQL
- Форма PHP для Excel
- Отправка электронной почты от Excel с помощью VBA - Outlook, добавляющий цвет фона
Вместо использования SendKeys (который отправит указанный вход в окно переднего плана, каким бы он ни был), вставьте текст, используя
Set objHTML = CreateObject("htmlfile") ClipboardText = objHTML.ParentWindow.ClipboardData.GetData("text") objMail.Body = ClipboardText
Или, что еще лучше, вообще не используйте буфер обмена и явно читайте текст текущего выбора в Excel и задайте свойство Body в Outlook:
objMail.Body = rngBody.Text
Я наконец-то понял. Дмитрий был на правильном пути, используя HTML-файл вместо простой копии / SendKeys.
Вот новый код:
Sub EmailReports() Dim rngSubject As Range Dim rngTo As Range Dim rngBody As Range Dim objOutlook As Object Dim objMail As Object Set objOutlook = CreateObject("Outlook.Application") Set objMail = objOutlook.CreateItem(0) xRow = ActiveCell.Row RMName = Sheets("Dashboard").Range("B" & xRow) LastTaskRow = Sheets(RMName).Range("A1") With Target Range("E" & xRow) = Format(Now(), "MM/DD/YYYY") End With Set rngTo = Range("C" & xRow) Set rngSubject = Worksheets("Dashboard").Range("K4") Set rngBody = Worksheets(RMName).Range("D4:E" & LastTaskRow) With objMail .To = rngTo .Subject = rngSubject .HTMLBody = RangetoHTML(rngBody) .Display End With Set objOutlook = Nothing Set objMail = Nothing End Sub
Он вызывает функцию, которую я нашел на веб-сайте Microsoft под названием «RangetoHTML»:
Function RangetoHTML(rng As Range) ' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010. Dim fso As Object Dim ts As Object Dim TempFile As String Dim TempWB As Workbook TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm" ' Copy the range and create a workbook to receive the data. rng.Copy Set TempWB = Workbooks.Add(1) With TempWB.Sheets(1) .Cells(1).PasteSpecial Paste:=8 .Cells(1).PasteSpecial xlPasteValues, , False, False .Cells(1).PasteSpecial xlPasteFormats, , False, False .Cells(1).Select Application.CutCopyMode = False On Error Resume Next .DrawingObjects.Visible = True .DrawingObjects.Delete On Error GoTo 0 End With ' Publish the sheet to an .htm file. With TempWB.PublishObjects.Add( _ SourceType:=xlSourceRange, _ Filename:=TempFile, _ Sheet:=TempWB.Sheets(1).Name, _ Source:=TempWB.Sheets(1).UsedRange.Address, _ HtmlType:=xlHtmlStatic) .Publish (True) End With ' Read all data from the .htm file into the RangetoHTML subroutine. Set fso = CreateObject("Scripting.FileSystemObject") Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2) RangetoHTML = ts.ReadAll ts.Close RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _ "align=left x:publishsource=") ' Close TempWB. TempWB.Close savechanges:=False ' Delete the htm file. Kill TempFile Set ts = Nothing Set fso = Nothing Set TempWB = Nothing End Function