Lotus Notes VBA多PDF附件添加报错及附件位置调整求助

错误原因分析 #

1. 参数类型不匹配：SendNotesMail子程序的Attachment参数定义为String，但调用时传入了数组Array(pathA, pathB)，类型冲突直接触发7368错误。
2. 重复创建富文本项：注释标记的错误行MailDoc.CREATERICHTEXTITEM ("Attachment")重复创建同名富文本项，即使参数类型正确也会引发对象定义错误。
3. 附件与正文顺序问题：原代码单独设置MailDoc.body文本和附件富文本项，无法控制附件在正文顶部显示。

修正后的完整代码 #

发送邮件子程序（修改版） #

Public Sub SendNotesMail(Subject As String, Attachments As Variant, Recipient As String, _
                        ccRecipient1 As String, ccRecipient2 As String, ccRecipient3 As String, ccRecipient4 As String, _
                        BodyText As String, SaveIt As Boolean)
    'Set up the objects required for Automation into lotus notes
    Dim Maildb As Object 'The mail database
    Dim UserName As String 'The current users notes name
    Dim MailDbName As String 'The current users notes mail database name
    Dim MailDoc As Object 'The mail document itself
    Dim BodyRTItem As Object 'Unified rich text item for body + attachments
    Dim Session As Object 'The notes session
    Dim EmbedObj As Object 'The embedded object (Attachment)
    Dim i As Integer 'Loop counter for attachments
    
    'Start a session to notes
    Set Session = CreateObject("Notes.NotesSession")
    'Get the sessions username and then calculate the mail file name
    UserName = Session.UserName
    MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
    'Open the mail database in notes
    Set Maildb = Session.GETDATABASE("", MailDbName)
    If Not Maildb.IsOpen Then
        Maildb.OPENMAIL
    End If
    
    'Set up the new mail document
    Set MailDoc = Maildb.CREATEDOCUMENT
    MailDoc.Form = "Memo"
    MailDoc.sendto = Recipient
    MailDoc.CopyTo = Array(ccRecipient1, ccRecipient2, ccRecipient3, ccRecipient4)
    MailDoc.Subject = Subject
    MailDoc.SAVEMESSAGEONSEND = SaveIt
    
    'Create unified rich text item for attachments + body (to place attachments on top)
    Set BodyRTItem = MailDoc.CREATERICHTEXTITEM("Body")
    
    'Add attachments first (so they appear at the top)
    If IsArray(Attachments) Then
        For i = LBound(Attachments) To UBound(Attachments)
            If Attachments(i) <> "" And Dir(Attachments(i)) <> "" Then 'Check if file exists
                Set EmbedObj = BodyRTItem.EMBEDOBJECT(1454, "", Attachments(i), "Attachment" & i)
            End If
        Next i
    ElseIf Attachments <> "" And Dir(Attachments) <> "" Then 'Handle single attachment case
        Set EmbedObj = BodyRTItem.EMBEDOBJECT(1454, "", Attachments, "Attachment")
    End If
    
    'Add body text after attachments
    If BodyText <> "" Then
        Call BodyRTItem.APPENDTEXT(BodyText)
        Call BodyRTItem.ADDPARAGRAPH 'Add line break after text
    End If
    
    'Send the document
    MailDoc.PostedDate = Now() 'Gets the mail to appear in the sent items folder
    MailDoc.send 0, Recipient
    
    'Clean Up
    Set Maildb = Nothing
    Set MailDoc = Nothing
    Set Session = Nothing
    Set EmbedObj = Nothing
    Set BodyRTItem = Nothing
End Sub

调用子程序（修改版） #

Sub callemail()
    Dim pathA As String
    Dim pathB As String
    Dim att As Variant 'Change to Variant to hold array
    
    pathA = ThisWorkbook.Worksheets("Foglio1").Range("G1").Value2
    pathB = ThisWorkbook.Worksheets("Foglio1").Range("F1").Value2
    
    att = Array(pathA, pathB)
    
    Call SendNotesMail("SCH61", att, "a@gmail.com", "b@gmail.com", "c@gmail.com", "d@gmail.com", "e@gmail.com", "test", True)
End Sub

关键改动说明 #

• 参数类型调整：将SendNotesMail的Attachment参数改为Variant，支持接收单个字符串或字符串数组。
• 统一富文本项：创建单个Body富文本项，先嵌入所有附件，再追加正文文本，确保附件显示在正文顶部。
• 文件存在检查：添加Dir(Attachments(i)) <> ""判断，避免因无效文件路径引发错误。
• 移除重复创建：删除原代码中重复创建富文本项的错误行。
• 循环处理多附件：通过For循环遍历附件数组，逐个嵌入到富文本项中。

内容的提问来源于stack exchange，提问作者AlessioFranzini