我使用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
答案 0 :(得分：0)
当我遇到类似的问题时，我发现将邮件的设置分成两部分，使得默认签名出现在准备好的邮件中。
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体。