使用此代码，我可以提取默认签名，并使用工作表中的内容发送电子邮件：
Function RangetoHTML(rng As Range)
' Works in Excel 2000,Excel 2002,Excel 2003,Excel 2007,Excel 2010,Outlook 2000,Outlook 2002,Outlook 2003,Outlook 2007,Outlook 2010,and Office 365.
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 workbook to receive the data.
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteAll
.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 an .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 the RangetoHTML subroutine.
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.
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Sub Regionmailer()
' Documentations for this macro is on the README.md file attached in this workbook.
' For debugging,comment out .send and uncomment .display
' CC to uncomment on publish
' Get email addresses
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olAL As Outlook.AddressList
Dim olEntry As Outlook.AddressEntry
Dim olMember As Outlook.AddressEntry
Dim lMemberCount As Long
Dim objMail As Outlook.MailItem
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olAL = olNS.AddressLists("Global Address List")
Set objMail = olApp.CreateItem(olMailItem)
' enter the list name
Set olEntry = olAL.AddressEntries("ABC")
' get count of dist list members
lMemberCount = olEntry.Members.Count
' loop through dist list and extract members
Dim p As Long
Dim sn As Long
Dim rn As Range
Dim firstName() As String
Dim dtime As Date
Dim StrBody As String
Dim StrBody2 As String
dtime = Now
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
ReDim EmailList(1 To lMemberCount,1 To 3) As String
For p = 1 To lMemberCount
Set olMember = olEntry.Members.Item(p)
EmailList(p,1) = olMember.Name 'LN,FN
EmailList(p,2) = olMember.GetExchangeUser.PrimarySmtpAddress 'Email
EmailList(p,3) = olMember.GetExchangeUser.OfficeLocation ' Office Location e.g. ABC - 123 - DoReMi
Next p
With objMail
.Display
Signature = .HTMLBody
End With
For sn = 1 To Sheets.Count
For p = 1 To lMemberCount
If activeSheet.Name = EmailList(p,1) And EmailList(p,3) = "ABC - 123 - DoReMi" Then
Set rn = Nothing
Set rn = activeSheet.UsedRange
With rn
.Borders(xlInsideVertical).Linestyle = xlContinuous
.Borders(xlInsideHorizontal).Linestyle = xlContinuous
.BorderAround xlContinuous
End With
firstName = Split(EmailList(p,1),",2)
With objMail
.HTMLBody = ""
.To = EmailList(p,2)
.Subject = "Subject as of" & dtime
StrBody = "<BODY style=font-size=11pt;font-family:Calibri>Hi " & firstName(1) & ",<br><br>" & _
"Lorem ipsum dolor sit amet,consectetur adipiscing elit,sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam,quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident,sunt in culpa qui officia deserunt mollit anim id est laborum."
StrBody2 = "<br><br>Regards,<br><br>"
.HTMLBody = StrBody & RangetoHTML(rn) & "<br>" & StrBody2 & Signature
'.Display
.Send 'to send
End With
Set objMail = olApp.CreateItem(olMailItem)
Exit For
End If
Next p
On Error Resume Next
Sheets(activeSheet.Index + 1).activate
If Err.Number <> 0 Then Sheets(1).activate
Next sn
End Sub
这里的问题是，每当我运行此代码时，签名图像只会出现在发送的第一封电子邮件中，而不会出现在发送的所有其他电子邮件中。
以下是使用此代码发送的其他电子邮件上的最终签名（出于隐私目的，此处不会显示带有图像屏幕截图的签名）：
也像reference一样，但这也不会显示图像，我也不想打开文件浏览器来选择签名。