向代码添加默认签名[重复]

Question

我正在使用 Ron De Bruin 的以下代码添加一些文本和范围，从 excel 电子表格到电子邮件正文。我对vba的了解有限。我还想在电子邮件中添加默认签名。任何有关如何调整此代码以做到这一点的帮助将不胜感激。非常感谢。

  Sub BOemail()
'
' BOemail Macro
'

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Username = Environ("username")


Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object

    Range("C1").Select
    ActiveCell.FormulaR1C1 = "Available"
    Range("A1").Select

Set rng = Nothing
' Only send the visible cells in the selection.

Set rng = Sheets("BOTable").Range("A1:D6").SpecialCells(xlCellTypeVisible)

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(0)


With OutMail
    .To = UserForm2.TextBox4.Text
    .CC = ""
    .BCC = ""
    .Subject = "Backorder"
    .HTMLBody = "Thank you for your order number" & " " & UserForm2.TextBox7.Value & "." & "<br><br>" & "Please see below as some of the items are currently out of stock.  At this time, we are planning to hold your order until we can ship it to you complete.  Please contact us if any of the items are available to ship and you want us to ship what we have now, and send the backordered items when they are available.<br><br>" & "We will keep you updated on your backorder." & RangetoHTML(rng)
    .Attachments.Add "C:\Users\" & Username & "\Dropbox\Ample Supply Information\Ample Supply Company Line Card.pdf"
    .Display
End With
On Error GoTo 0

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

Set OutMail = Nothing
Set OutApp = Nothing

 Exit Sub

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub


Function RangetoHTML(rng As Range)
' By Ron de Bruin.
    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

Answer 1

当我遇到类似问题时，我发现将邮件设置分成两部分会使默认签名出现在准备好的邮件中。

    Dim OutSig As String

    With OutMail
        .display
        OutSig = .HTMLBody           ' here the signature is included
    End With
    With OutMail
        .To = MailList
        .Subject = Subj
        .Importance = 2
        .HTMLBody = RangeToHTML(MailRng) & OutSig
        .display
'        .Send
    End With

我记得，第一部分中的.display 命令也是必需的。我在运行该代码之前关闭了 ScreenUpdating。

根据您的要求，我已将上述想法实施到您自己的代码中，并在此过程中进行了一些更正和改进。但是我无法测试代码，如果它不适合你，我很遗憾。

Option Explicit

Sub BOemail()
    ' 18 Dec 2017

    Dim Rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim UserName As String
    Dim OutSig As String
    Dim Txt As String

    UserName = Environ("username")
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With

    Range("C1").FormulaR1C1 = "Available"
'    Range("A1").Select

    On Error Resume Next            ' error if no cells a visible
    Set Rng = Sheets("BOTable").Range("A1:D6").SpecialCells(xlCellTypeVisible)
    If Err Then
        MsgBox "The selection is not a range or the sheet is protected. " & _
               vbNewLine & "Please correct and try again.", vbOKOnly
        Exit Sub
    End If
    On Error GoTo 0

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

    With OutMail
        .display
        OutSig = .HTMLBody           ' here the signature is included
    End With

    Txt = "Thank you for your order number " & UserForm2.TextBox7.Value & "." & vbCr & _
          "Please see below as some of the items are currently out of stock.  " & _
          "At this time, we are planning to hold your order until we can ship" & _
          "it to you complete.  Please contact us if any of the items are " & _
          "available to ship and you want us to ship what we have now, and " & _
          "send the backordered items when they are available." & vbCr & _
          "We will keep you updated on your backorder."

    With OutMail
        .To = UserForm2.TextBox4.Text
    '    .CC = ""
    '    .BCC = ""
        .Subject = "Backorder"
        .HTMLBody = Txt & RangetoHTML(Rng) & OutSig
        .Attachments.Add "C:\Users\" & UserName & "\Dropbox\Ample Supply Information\" & _
                             "Ample Supply Company Line Card.pdf"
        .display
    End With

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

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

重要的是，当您第一次创建 OutMail 对象并显示它时，会包含默认签名。因此，HTMLbody 被写入字符串OutSig，它基本上只包含签名。当您下次更改 HTMLbody 时，签名会丢失，但由于它保留在字符串 OutSig 中，您可以再次将其附加到替换原始 HTMLbody 的新 HTMLbody 中。