将 Excel 文件另存为 PDF，然后通过 Outlook 作为附件发送，但消息中没有签名

Question

我有一些 Excel VBA 代码将活动工作表另存为 PDF，然后将该 PDF 文件附加到 Outlook 新邮件中，一切正常，除了代码启动 Outlook 和新邮件时 Outlook 中的签名，尽管它在 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 P.O to be delivered to " & Cells(10, 12)


PdfPath = Save_as_pdf
EnvoiMail Right(PdfPath, InStr(1, StrReverse(PdfPath), "\") - 1), "recepient1@domain.com;recepient2@domain.com", , , 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           '"marcel@machin.com;julien@chose.com"
      .cc = CCdest            '"chef@machin.com;directeur@chose.com"
      .bcc = CCIdest          '"un.copain@supermail.com;une-amie@hotmail.com"
      .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

感谢尤金·阿斯塔菲耶夫 我改变了一些代码，我终于让它工作了

修改部分如下：

Sub EnvoiMail（主题为字符串，Destina 为字符串，可选的 CCdest 为字符串，可选的 CCIdest 为字符串，可选的 BoDyTxt 为字符串，可选的 NbPJ 为整数，可选的 PjPaths 为字符串） 将 MonOutlook 调暗为对象 将 MonMessage 调暗为对象 Dim strbody As String '我添加了这部分 >>'

设置 MonOutlook = CreateObject("Outlook.Application") 设置 MonMessage = MonOutlook.CreateItem(0) strbody = "Hello" ' 我也把我的消息放在这里，我在我的主代码中更改它以从单元格中获取值 >>'

将 PJ() 调暗为字符串 PJ() = Split(PjPaths, ";")

使用 MonMessage .display ' >>>'

  .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 = 无 结束子

Answer 2

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

.BoDy = BoDyTxt

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

.Body = BoDyTxt & .Body

在这种情况下，文本将插入消息的开头，保持签名不变。

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

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

您可以在 MSDN 的Chapter 17: Working with Item Bodies 中阅读有关所有这些方式的更多信息。