VBA добавляет подпись к электронной почте, которая использует функцию RangetoHTML (rng to Range) - PullRequest
Новая
       9

VBA добавляет подпись к электронной почте, которая использует функцию RangetoHTML (rng to Range)

0 голосов
/ 06 сентября 2018

У меня есть следующий код, и он почти идеально создает электронную почту. Чего он не делает, так это поддерживает подпись по умолчанию, видимую до вставки результатов RangetoHTML.

Как мне вернуть мою подпись?

Это почти полностью взято из примеров кода Рона де Брейна, и, как я уже сказал, все работает очень хорошо, за исключением бита подписи. Это подпись, созданная Outlook, поэтому у меня есть локальная копия htm. Я провел эксперимент и обнаружил, что после «.body = Selection.Paste» ничего, даже дополнительный текст или другая строка, не появится. Нет, если изменить его на «.HTMLbody = Selection.Paste», это не заставит его работать. 

Sub Mail_Reminder_Thursday()
'Emailing Script for Thursday Reminder
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim rng As Range
Dim sendBCC As String
    sendBCC = ""
Dim emailCell As Range
Dim Signature As String

With ActiveSheet

' Cycle through email addresses, from B3 to one before next blank cell in     column
For Each emailCell In .Range("D2", .Range("D2").End(xlDown))
If .Cells(emailCell.Row, "C").Text = "YES" Then

        sendBCC = sendBCC & "; " & emailCell.Text

    End If

Next emailCell

End With

Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Sheets("WEEKLY   MATCHUPS").Range("T1:Z18").SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If rng Is Nothing Then
    MsgBox "The selection is not a range or the sheet is protected" & _
           vbNewLine & "please correct and try again.", vbOKOnly
    Exit Sub
End If

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

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

            On Error Resume Next

        With OutMail
            .BodyFormat = 2
            .Display
            .BCC = sendBCC
            .Subject = "Week " & Sheets("WEEKLY MATCHUPS").Range("A1") & " - Thursday Reminder"
            .HTMLBody = "This is just a friendly reminder that your pick for tonight's Thursday Night Football game is due by kickoff @ " & Format(Sheets("WEEKLY MATCHUPS").Range("M3"), "medium time") & "<BR>" & "<BR>" & _
                         RangetoHTML(rng)
                        .Body = Selection.Paste 
            .Display
        End With

        On Error GoTo 0

        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With

Set OutMail = Nothing
Set OutApp = Nothing

End Sub

Function RangetoHTML(rng As Range)

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 paste 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 Ответ

0 голосов
/ 06 сентября 2018

Хитрость в том, что Outlook добавляет подпись только тогда, когда вы .Display электронное письмо, и только , если вы не уже внесли изменения в .HTMLBody: 

Dim DefaultSignature As String
.Display
DefaultSignature = .HTMLBody

.HTMLBody = "This is just a friendly reminder that your pick for tonight's Thursday Night Football game is due by kickoff @ " & Format(ThisWorkbook.Worksheets("WEEKLY MATCHUPS").Range("M3").Value, "medium time") & "<BR>" & "<BR>" & _
    RangetoHTML(rng) & DefaultSignature
...