Excel VBA 到 Outlook 正文的范围 - 需要帮助以添加默认签名

Question

目前我正在使用此 VBA 代码将所选 excel 范围复制到 outlook 中的新电子邮件：

Sub SendSelectedCells_inOutlookEmail()
Dim objSelection As Excel.Range
Dim objTempWorkbook As Excel.Workbook
Dim objTempWorksheet As Excel.Worksheet
Dim strTempHTMLFile As String
Dim objTempHTMLFile As Object
Dim objFileSystem As Object
Dim objTextStream As Object
Dim objOutlookApp As Outlook.Application
Dim objNewEmail As Outlook.MailItem

'Copy the selection
Set objSelection = Selection
Selection.Copy

'Paste the copied selected ranges into a temp worksheet
Set objTempWorkbook = Excel.Application.Workbooks.Add(1)
Set objTempWorksheet = objTempWorkbook.Sheets(1)

'Keep the values, column widths and formats in pasting
With objTempWorksheet.Cells(1)
     .PasteSpecial xlPasteValues
     .PasteSpecial xlPasteColumnWidths
     .PasteSpecial xlPasteFormats
End With

'Save the temp worksheet as a HTML file
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
strTempHTMLFile = objFileSystem.GetSpecialFolder(2).Path & "\Temp for Excel" & Format(Now, "YYYY-MM-DD hh-mm-ss") & ".htm"
Set objTempHTMLFile = objTempWorkbook.PublishObjects.Add(xlSourceRange, strTempHTMLFile, objTempWorksheet.Name, objTempWorksheet.UsedRange.Address)
objTempHTMLFile.Publish (True)

'Create a new email
Set objOutlookApp = CreateObject("Outlook.Application")
Set objNewEmail = objOutlookApp.CreateItem(olMailItem)

'Read the HTML file data and insert into the email body
Set objTextStream = objFileSystem.OpenTextFile(strTempHTMLFile)
objNewEmail.HTMLBody = objTextStream.ReadAll
objNewEmail.Display
'You can specify the new email recipients, subjects here using the following lines:
'objNewEmail.To = "johnsmith@datanumen.com"
'objNewEmail.Subject = "DataNumen Products"
'objNewEmail.Send --> directly send out this email

objTextStream.Close
objTempWorkbook.Close (False)
objFileSystem.DeleteFile (strTempHTMLFile)
End Sub

它有效，但它没有将我的默认签名添加到新电子邮件中， 有人可以帮我解决这个问题吗？

感谢大家的帮助。

编辑： 这是带有默认签名的宏

Sub SendSelectedCells_inOutlookEmail()
Dim objSelection As Excel.Range
Dim objTempWorkbook As Excel.Workbook
Dim objTempWorksheet As Excel.Worksheet
Dim strTempHTMLFile As String
Dim objTempHTMLFile As Object
Dim objFileSystem As Object
Dim objTextStream As Object
Dim objOutlookApp As Outlook.Application
Dim objNewEmail As Outlook.MailItem
Dim strSig As String

'Copy the selection
Set objSelection = Selection
Selection.Copy

'Paste the copied selected ranges into a temp worksheet
Set objTempWorkbook = Excel.Application.Workbooks.Add(1)
Set objTempWorksheet = objTempWorkbook.Sheets(1)

'Keep the values, column widths and formats in pasting
With objTempWorksheet.Cells(1)
     .PasteSpecial xlPasteValues
     .PasteSpecial xlPasteColumnWidths
     .PasteSpecial xlPasteFormats
End With

'Save the temp worksheet as a HTML file
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
strTempHTMLFile = objFileSystem.GetSpecialFolder(2).Path & "\Temp for Excel" & Format(Now, "YYYY-MM-DD hh-mm-ss") & ".htm"
Set objTempHTMLFile = objTempWorkbook.PublishObjects.Add(xlSourceRange, strTempHTMLFile, objTempWorksheet.Name, objTempWorksheet.UsedRange.Address)
objTempHTMLFile.Publish (True)

'Create a new email
Set objOutlookApp = CreateObject("Outlook.Application")
Set objNewEmail = objOutlookApp.CreateItem(olMailItem)

'Read the HTML file data and insert into the email body
Set objTextStream = objFileSystem.OpenTextFile(strTempHTMLFile)
objNewEmail.Display
strSig = objNewEmail.HTMLBody
objNewEmail.HTMLBody = objTextStream.ReadAll & strSig

'You can specify the new email recipients, subjects here using the following lines:
'objNewEmail.To = "johnsmith@datanumen.com"
'objNewEmail.Subject = "DataNumen Products"
'objNewEmail.Send --> directly send out this email

objTextStream.Close
objTempWorkbook.Close (False)
objFileSystem.DeleteFile (strTempHTMLFile)

结束子

谢谢德米特里的帮助！

Answer 1

如果您调用 MailItem.Display 并且您在调用 Display 之前没有修改 Body 或 HTMLBody 属性，则 Outlook 会添加签名。

先调用Display，阅读HTNMLBody 属性（它将包含签名），然后将其与您的数据合并。