Question

我正在使用以下代码使用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

请有人告诉我我哪里出错了吗？

Answer 1

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

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

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

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

1 个答案: