从excel / vba生成电子邮件到Outlook时，我的电子邮件签名不会显示？
嗨，我使用了Ron De Bruin的精彩网站来创buildVBA代码，它可以从excel文件中生成一封电子邮件给特定的用户。
唯一的问题是，我的签名不会出现在每封电子邮件，我似乎无法find如何将其添加到代码中？
任何人都可以build议吗？
正如你可以告诉我是一个完整的新手！
第一单元
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
将您的签名转换为HTMLstring并将其添加到电子邮件中。 喜欢这个：
Dim mySignature As String mySignature = "<p>Best Regards,<p>Your name and company<p>" With OutMail .to = Cws.Cells(Rnum, 1).Value .Subject = "Test mail" .HTMLBody = strbody & RangetoHTML(Rng) & mySignature .Display 'Or use Send End With
请试试看看您的问题是否得到解决…
With OutMail .BodyFormat = 2 .Display = True .To = Cws.Cells(Rnum, 1).Value .Subject = "Test mail" .HTMLBody = strbody & RangetoHTML(rng) & "<br>" & .HTMLBody '.Send 'To send End With
如果要用下面的代码replace第一部分中的所有内容，我相信它应该可以工作，只要记住replace.htm签名文件的名称并编辑该htm以包含所有图像源为绝对：
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 Dim SigString As String Dim Signature As Variant On Error GoTo cleanup Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) 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>" SigString = Environ("appdata") & _ "\Microsoft\Signatures\YourSignature.htm" 'CHANGE ABOVE TO YOUR SIGNATURE NAME .htm 'Make sure that the Htm file has all sources defined with absolute references 'so if an image's src=\img\signature.jpg, then you should change \img\signature to something like: 'C:\Users\Me\AppData\Roaming\Microsoft\Signatures\ If Dir(SigString) <> "" Then Signature = GetBoiler(SigString) Else Signature = "" End If '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) & "<br>" & Signature .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 Function GetBoiler(ByVal sFile As String) As String 'https://www.rondebruin.nl/win/s1/outlook/signature.htm Dim fso As Object Dim ts As Object Set fso = CreateObject("Scripting.FileSystemObject") Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2) GetBoiler = ts.readall ts.Close End Function