在发送之前将 IBM Notes 电子邮件打印/保存为 PDF？答案

【问题标题】：Print/Save IBM Notes Email as PDF before sending?在发送之前将 IBM Notes 电子邮件打印/保存为 PDF？
【发布时间】：2017-08-13 08:45:36
【问题描述】：

我正在使用下面的代码使用 IBM Notes 从 excel 创建和发送电子邮件。

我已经尝试过将此电子邮件作为 PDF 保存到文件夹中，或者只是打印它以便我可以将其打印为 PDF。

无论我尝试什么，我似乎都无法将其打印/保存为 PDF。其余代码工作正常。

我接近了，通过使用这段代码（它保存了每封电子邮件的附件，因为它正在创建）。

Attachment = Range("F" & i).value
Set AttachME = doc.CREATERICHTEXTITEM("attachment")
Set EmbedObj = AttachME.EmbedObject(1454, "", Attachment, "")
EmbedObj .ExtractFile "C:\attach\" & EmbedObj .Name

我什至尝试将其更改为：

Set doc = db.CreateDocument
doc.ExtractFile "C:\attach\" & "SomeFileName.pdf"

但这会产生一个对象不支持此属性或方法的错误。我也在尝试这个：

doc.Print True, False

但还是没有运气。

我的完整代码：

Sub Send()
ActiveSheet.DisplayPageBreaks = False
Dim answer As Integer
    answer = MsgBox("Are you sure you want to Send All Announcements?", vbYesNo + vbQuestion, "Notice")
    If answer = vbNo Then
    Exit Sub

    Else

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim Attachment As String
Dim WB3 As Workbook
Dim WB4 As Workbook
Dim Rng As Range
Dim db As Object
Dim doc As Object
Dim body As Object
Dim header As Object
Dim stream As Object
Dim session As Object
Dim i As Long
Dim j As Long
Dim j2 As Long
Dim server, mailfile, user, usersig As String
Dim LastRow As Long, LastRow2 As Long, WS As Worksheet
LastRow = Worksheets(1).Range("F" & Rows.Count).End(xlUp).Row  'Finds the last used row

j = 18

With ThisWorkbook.Worksheets(1)

For i = 18 To LastRow


'Start a session of Lotus Notes
Set session = CreateObject("Notes.NotesSession")
'This line prompts for password of current ID noted in Notes.INI
Set db = session.CurrentDatabase
Set stream = session.CreateStream
' Turn off auto conversion to rtf
session.ConvertMime = False



'Email Code

'Create email to be sent

Set doc = db.CreateDocument
doc.Form = "Memo"
Set body = doc.CreateMIMEEntity
Set header = body.CreateHeader("Promotion Announcement for week " & Range("I8").value & ", " & Range("T8").value & " - Confirmation required")
Call header.SetHeaderVal("HTML message")

'Set From
Call doc.ReplaceItemValue("Principal", "Food Specials <mailto:Food.Specials@Lidl.co.uk>")
Call doc.ReplaceItemValue("ReplyTo", "Food.Specials@Lidl.co.uk")
Call doc.ReplaceItemValue("DisplaySent", "Food.Specials@Lidl.co.uk")

Call doc.ReplaceItemValue("Subject", "Promotion Announcement for week " & Range("I8").value & ", " & Range("T8").value & " - Confirmation required")

'To
Set header = body.CreateHeader("To")
Call header.SetHeaderVal(Range("N" & i).value)


'Email Body
Call stream.WriteText("<HTML>")
Call stream.WriteText("<font size=""3"" color=""black"" face=""Arial"">")
Call stream.WriteText("<p>Good " & Range("A1").value & ",</p>")
Call stream.WriteText("<p>Please see attached an announcement of the spot buy promotion for week " & Range("I8").value & ", " & Range("T8").value & ".<br>Please check, sign and send this back to us within 24 hours in confirmation of this order. Please also inform us of when we can expect the samples.</p>")
Call stream.WriteText("<p>The details are as follows:</p>")

'Insert Range
Set WB3 = Workbooks.Open(Range("F" & i).value)
With WB3.Sheets(1)
.Range("A20:J39").SpecialCells(xlCellTypeVisible).Select
Set Rng = Selection
End With

Call stream.WriteText(RangetoHTML(Rng))
WB3.Close SaveChanges:=False


'Attach file
Attachment = Range("F" & i).value
Set AttachME = doc.CREATERICHTEXTITEM("attachment")
Set EmbedObj = AttachME.EmbedObject(1454, "", Attachment, "")


Call stream.WriteText("<BR><p>Please note the shelf life on delivery should be 75% of the shelf life on production.</p></br>")
'Signature
Call stream.WriteText("<BR><p>Kind regards / Mit freundlichen Gr&#252;&#223;en,</p></br>")
Call stream.WriteText("<p><b>Lidl UK Food Specials Team</b></p>")

Call stream.WriteText("<table border=""0"">")
Call stream.WriteText("<tr>")
Call stream.WriteText("<td><img src=""http://www.lidl.co.uk/statics/lidl-uk/ds_img/layout/top_logo2016.jpg"" alt=""Mountain View""></td>")
Call stream.WriteText("<td><img src=""http://www.lidl.co.uk/statics/lidl-uk/ds_img/assets_x_x/BOQLOP_NEW%281%29.jpg"" alt=""Mountain View""></td>")
Call stream.WriteText("</tr>")
Call stream.WriteText("</table>")


Call stream.WriteText("</font>")
Call stream.WriteText("</body>")
Call stream.WriteText("</html>")

Call body.SetContentFromText(stream, "text/HTML;charset=UTF-8", ENC_IDENTITY_7BIT)

doc.Print True, False

doc.Save True, False
Call doc.PutInFolder("TEST")

Call doc.Send(False)

session.ConvertMime = True ' Restore conversion - very important


'Clean Up the Object variables - Recover memory
    Set db = Nothing
    Set session = Nothing
    Set stream = Nothing
    Set doc = Nothing
    Set body = Nothing
    Set header = Nothing

    'WB3.Close savechanges:=False

    Application.CutCopyMode = False

'Email Code

j = j + 1

Next i
End With




Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Success!" & vbNewLine & "Announcements have been sent."
MsgBox doc.GetItemValue("subject")(0)

End If
End Sub




Function RangetoHTML(Rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    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

请谁能告诉我哪里出错了？

【问题讨论】：

标签： vba email pdf lotus-notes

【解决方案1】：

Notes API 无法将消息另存为 PDF。

您不能将范围传递给 EmbedObject。 EmbedObject 需要一个文件名 - 用于您已经保存到磁盘的文件。您可以使用 EmbedObject 创建 PDF 并将其附加到电子邮件中。如果有人已经创建了 PDF 并将其附加到电子邮件中，您可以使用 ExtractFile 将 PDF 保存到磁盘 - 正如您在第二次尝试中发现的那样，它是 NotesRichTextItem 类的方法，而不是 NotesDocument 类的方法。至于你最后的尝试，NotesDocument 类也没有打印方法。

据我所知，将 Notes 电子邮件保存为 PDF 文件的唯一解决方案需要第三方商业软件。（OpenNTF网站上有一些与PDF相关的开源项目，但我相信它们都是基于Lotus XPages技术的，你无法从VBA访问。）

【讨论】：