将Excel文件保存为PDF格式，然后通过Outlook作为附件发送，但在邮件中没有签名

我有一些Excel VBA代码，将活动工作表保存为PDF，然后将该PDF文件附加到Outlook新邮件一切工作正常，除了在Outlook中的签名时，代码启动Outlook和新邮件它不显示签名，尽pipe它在HTML中，我可以已经手动插入。 所以任何调整的代码将不胜感激。

Sub Send_To_Pdf() Dim PdfPath As String Dim BoDy As String BoDy = Msg = "Dear Mr. " & vbCrLf & vbCrLf & "Good Day" & vbCrLf & vbCrLf & "Kindly find the attahched PO to be delivered to " & Cells(10, 12) PdfPath = Save_as_pdf EnvoiMail Right(PdfPath, InStr(1, StrReverse(PdfPath), "\") - 1), "[e-mail];[e-mail]", , , BoDy, 1, PdfPath End Sub Public Function Save_as_pdf() As String Dim FSO As Object Dim s(1) As String Dim sNewFilePath As String Set FSO = CreateObject("Scripting.FileSystemObject") s(0) = "C:\Users\" & Environ("UserName") & "\Desktop\" & ThisWorkbook.Name If FSO.FileExists(ThisWorkbook.FullName) Then '//Change Excel Extension to PDF extension in FilePath s(1) = FSO.GetExtensionName(s(0)) If s(1) <> "" Then s(1) = "." & s(1) sNewFilePath = Replace(s(0), s(1), ".pdf") '//Export to PDF with new File Path ActiveSheet.ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:=sNewFilePath, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, _ IgnorePrintAreas:=False, OpenAfterPublish:=False End If Else '//Error: file path not found MsgBox "Error: this workbook may be unsaved. Please save and try again." End If Set FSO = Nothing Save_as_pdf = sNewFilePath End Function Sub EnvoiMail(Subject As String, Destina As String, Optional CCdest As String, Optional CCIdest As String, Optional BoDyTxt As String, Optional NbPJ As Integer, Optional PjPaths As String) Dim MonOutlook As Object Dim MonMessage As Object Set MonOutlook = CreateObject("Outlook.Application") Set MonMessage = MonOutlook.createitem(0) Dim PJ() As String PJ() = Split(PjPaths, ";") With MonMessage .Subject = Subject '"Je suis content" .To = Destina '"[e-mail];[e-mail]" .cc = CCdest '"[e-mail];[e-mail]" .bcc = CCIdest '"[e-mail];[e-mail]" .BoDy = BoDyTxt If PjPaths <> "" And NbPJ <> 0 Then For i = 0 To NbPJ - 1 'MsgBox PJ(I) .Attachments.Add PJ(i) '"C:\Mes Documents\Zoulie Image.gif" Next i End If .display '.send '.Attachments.Add ActiveWorkbook.FullName End With '?plusieurs?MonMessage.Attachments.Add "D:\Prof\Janvier\Base clients.mdb" Set MonOutlook = Nothing End Sub 

Answer 1

在创build新消息之后，您需要在默认签名（不覆盖它）之前插入一个新的文本，例如：

 .BoDy = BoDyTxt 

在这种情况下，默认签名将被删除。

 .Body = BoDyTxt & .Body 

在这种情况下，文本将被插入到消息的开头，使签名保持原样。

Outlook对象模型提供了三种不同的方式来处理项目实体：

1. 正文 – 一个纯文本。
2. HTMLBody – 一个HTML标记。
3. Word编辑器。 Outlook使用Word作为电子邮件编辑器，因此您可以使用它来格式化电子邮件。 Inspector类的WordEditor属性返回表示消息正文的Document类的实例。

有关所有这些方法的更多信息，请参阅第17章：在MSDN中使用项目实体 。

Answer 2

感谢尤金Astafiev我改变了一些代码，我终于工作了

改变的部分如下：

Sub EnvoiMail（主题为string，Destina为string，可选的CCdest为string，可选的CCIdest为string，可选的BoDyTxt为string，可选的NbPJ为整数，可选的PjPaths为string）Dim MonOutlook As Object Dim MonMessage As Object Dim strbody As String'i添加了这部分<< >>>'

设置MonOutlook = CreateObject（“Outlook.Application”）设置MonMessage = MonOutlook.CreateItem（0）strbody =“你好”我把我的消息在这里以及我改变它在我的主要代码，以获取单元格的值<<<< >>>”

Dim PJ（）As String PJ（）= Split（PjPaths，“;”）

用MonMessage .Display'<<<<<解决50％问题的代码最重要的部分>>>>'

  .Subject = Subject .To = Destina .CC = CCdest .BCC = CCIdest .HTMLBoDy = strbody & "<br>" & .HTMLBoDy ' <<<< the second import part of the code and solved the other 50% >>>>> ' If PjPaths <> "" And NbPJ <> 0 Then For i = 0 To NbPJ - 1 'MsgBox PJ(I) .Attachments.Add PJ(i) Next i End If .Display '.send 

结束

设置MonOutlook = Nothing End Sub