Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Макрос отправки почты
 
#1
04.08.2022 15:00:26
Всем привет. У меня есть макрос, который отправляет письма. Меня все устраивает, кроме одного момента.

Он копирует таблицу и создав новое письмо, вставляет ее туда. Но иногда он не вставляет.  Создает письмо, заполняет все данные, но не вставляет скопированную таблицу.
Как будто создал письмо, но не нажал на окошко письма (не активировал его) и вставил в пустоту.

Как можно это поправить? чтобы стабильнее работал.
Код
Dim objOutlookApp As Object, objMail As Object
    Application.ScreenUpdating = False
    On Error Resume Next
    Set objOutlookApp = CreateObject("Outlook.Application")
    Err.Clear
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    Set objMail = objOutlookApp.CreateItem(0)   
    If Err.number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
    
    
    With objMail
        
        
        .To = toMail
        .CC = "SSS" 
        .Subject = Range("B4").Value + "   |   " + Range("D4").Value
        .BodyFormat = 2  
        .Display '
        DoEvents
        
        
        Application.SendKeys "^v"
    End With
 
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
Изменено: Руслан Нестеренко - 04.08.2022 15:01:13
 
 
 
#2
04.08.2022 15:30:08
Самый стабильный способ: часть таблицы сохранять в html, этот кусок вставлять в письмо.
Менее стабильный вариант, но более стабильный чем #1, выполнять копирование поближе к вставке.
Код
Range("A1:Z100").Copy
DoEvents
Application.SendKeys "^v"
 
 
 
#3
04.08.2022 15:47:34
При переводе в HTHL  он таблицу не полностью копирует.

Например есть 6 столбцов. В каждой ячейке может быть от 10 символов до 200 например. Если просто переводить в HTML и не раздвигать таблицу, то он копирует ее но значения ячеек урезаны. А способ который выше, он копирует полностью
 
 
 
#4
04.08.2022 17:58:21
Цитата
Руслан Нестеренко написал:
А способ который выше, он копирует полностью
Магия... Особенно с учетом полного отсутствия даже намеков на попытку копирования чего либо.  :D
 
 
 
#5
04.08.2022 19:09:10
Ну вот смотрите, если пользоваться например вот этим макросом и функцией, то он вставляет в письмо таблицу, но вставляет ее так как она в экселе выглядит.
Если столбец сильно сжат, то  он и выведет в письме этот стлбец сжатым и с обрезанными значениями. А мне нужно, чтобы он значения ячеек полностью вставлял. Потому что они могут быть как короткие так и длинные.  И не хотелось бы при каждом отправлении регулировать ее в самом экселе.
Код
Sub email_range()

Dim OutApp As Object
Dim OutMail As Object
Dim count_row, count_col As Integer
Dim pop As Range
Dim str1, str2 As String


Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)


count_row = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlDown)))
count_col = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlToRight)))

Set pop = Sheets("Population Data").Range(Cells(1, 1), Cells(count_row, count_col))

str1 = "<BODY style = font-size:12pt;font-family:Calibri>" & "Привет я тут"

str2 = "<br>Да да да<br>"

On Error Resume Next
    With OutMail
        .to = "test@ma.ryt"
        .CC = ""
        .BCC = ""
        .Subject = "Tut chtoto pishem"
        .Display
        .HTMLBody = str1 & RangetoHTML(pop) & str2 & .HTMLBody
    End With
    On Error GoTo 0
    
Set OutMail = Nothing
Set OutApp = Nothing


End Sub



Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    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 new workbook to past the data in
    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 a 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 RangetoHTML
    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 we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
 
 
 
Страницы: 1
Наверх