vba 添加outlook 签名_从excel / vba向Outlook生成电子邮件时，我的电子邮件签名不会出现？...

Hi I have used the Ron De Bruin's fantastic website to create VBA code that generates an email to specic users from an excel file.

The only thing is that my signature does not appear on each email and I cannot seem to find how to add it within the code?

Would anyone be able to advise please?

As you can tell I am a complete novice!

Module 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 = "

Hi;

Please see below details of outstanding files. We will require these by 25th December 2017. Please feel free to respond with any questions.

Thank you."

'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

Module 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

解决方案

Translate your signature to a HTML string and add it to the email. Like this:

Dim mySignature As String

mySignature = "

Best Regards,

Your name and company

"

With OutMail

.to = Cws.Cells(Rnum, 1).Value

.Subject = "Test mail"

.HTMLBody = strbody & RangetoHTML(Rng) & mySignature

.Display 'Or use Send

End With