【发布时间】：2018-05-26 05:56:55
【问题描述】：
您好，我使用 Ron De Bruin 的精彩网站创建了 VBA 代码，该代码可以从 excel 文件生成电子邮件给特定用户。
唯一的问题是我的签名没有出现在每封电子邮件上，而且我似乎找不到如何在代码中添加它？
谁能给点建议？
如你所知，我是个新手！
模块 1
Option Explicit Sub Send_Row_Or_Rows_2()
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim strbody As String
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet
strbody = "<BODY style=font-size:11pt;font-family:Calibri>Hi;<p>Please see below details of outstanding files. We will require these by 25th December 2017. Please feel free to respond with any questions.<p>Thank you.</BODY>"
'Set filter range and filter column (column with e-mail addresses)
Set FilterRange = Ash.Range("A1:L" & Ash.Rows.Count)
FieldNum = 2 'Filter column = B because the filter range start in column A
'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True
'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount
'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value
'If the unique value is a mail addres create a mail
If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = Cws.Cells(Rnum, 1).Value
.Subject = "Test mail"
.HTMLBody = strbody & RangetoHTML(rng)
.Display 'Or use Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
'Close AutoFilter
Ash.AutoFilterMode = False
Next Rnum
End If
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
模块 2：
Option Explicit
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
Dim strbody As String
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
【问题讨论】：
-
使用代码创建自动电子邮件时，无法显示您的签名。
-
您是否尝试动态创建签名？你想用 "TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"" 来完成什么？
-
@braX 如果您的签名保存为 .htm 并且保存在您计算机的某个位置（只要图像的 src 是绝对的），那么我自己就可以这样做。
-
没错，你可以模拟签名并添加进去，但不能模拟实际签名本身。
-
如果你创建了一个模板
.oft文件，你可以使用你的默认签名。这是我的替代品