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的新HTML体。

向代码添加默认签名

1 个答案: