VBA 通过 IBM Notes 发送电子邮件不起作用？

Question

我正在使用以下 vba 代码尝试从 IBM Notes 发送带有附件的电子邮件。

这是我的代码：

 Sub Send_Email()

    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

    'Define Parameters for Email
     Dim s As Object
     Dim db As Object
     Dim body As Object
     Dim bodyChild As Object
     Dim header As Object
     Dim stream As Object
     Dim host As String
     Dim MailDoc As Object

    'Define Sheet Parameters

    Dim i As Long
    Dim j As Long
    Dim server, mailfile, user, usersig As String
    Dim LastRow As Long, ws As Worksheet
    LastRow = Worksheets(1).Range("F" & Rows.Count).End(xlUp).Row  'Finds the last used row

    j = 18


    '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





    With ThisWorkbook.Worksheets(1)

    For i = 18 To LastRow



    ' Create message
    Set MailDoc = db.CreateDocument
    MailDoc.Form = "Memo"

    'Set From
    MailDoc.SendTo = Range("Q" & i).value

    MailDoc.SentBy = "Food.Specials@Lidl.co.uk"
    MailDoc.tmpDisplaySentBy = "Food.Specials@Lidl.co.uk"
    MailDoc.FROM = "Food.Specials@Lidl.co.uk"
    MailDoc.SendFrom = "Food.Specials@Lidl.co.uk"
    MailDoc.Principal = "Food Specials <mailto:Food.Specials@Lidl.co.uk>"

    MailDoc.Subject = "Promotion Announcement for week " & Range("I8").value & ", " & Range("T8").value & " - Confirmation required"


    'MailDoc.SendTo = Range("Q" & i).value
    'Call MailDoc.ReplaceItemValue("CopyTo", "food.specials@lidl.co.uk")

    MailDoc.SaveMessageOnSend = True

    ' Create the body to hold HTML and attachment
    Set body = MailDoc.CreateMIMEEntity
    'Child mime entity which is going to contain the HTML which we put in the stream
    Set bodyChild = body.CreateChildEntity()
    Call stream.WriteText(strbody)
    Call bodyChild.SetContentFromText(stream, "text/html;charset=iso-8859-1", ENC_NONE)
    Call stream.Close
    Call stream.Truncate


    ' Get the attachment file name
    filename = Range("F" & i).value
    'A new child mime entity to hold a file attachment
    Set header = bodyChild.CreateHeader("Content-Type")
    Call header.SetHeaderVal("multipart/mixed")
    Set header = bodyChild.CreateHeader("Content-Disposition")
    Call header.SetHeaderVal("attachment; filename=" & filename)
    Set header = bodyChild.CreateHeader("Content-ID")
    Call header.SetHeaderVal(filename)
    Set stream = Session.CreateStream()




    Call bodyChild.SetContentFromBytes(stream, "application/msexcel", ENC_IDENTITY_BINARY) ' All my attachments are excel this would need changing depensding on your attachments.
    'Call bodyChild.SetContentFromBytes(1454, "", Range("F" & i).value, "Attachment")


    'Send the email
    Call MailDoc.Send(False)

    Session.ConvertMime = True ' Restore conversion










        j = j + 1

                   Next i
                   End With




    'Clean Up the Object variables - Recover memory


        Application.CutCopyMode = False


    MsgBox "Success!" & vbNewLine & "Announcements have been sent."

    End If

    End Sub

它似乎不想附加任何附件或发送。 我收到一个错误：对象变量或未在此行设置块变量：

Call header.SetHeaderVal("multipart/mixed")

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

编辑 2：

好的，我设法消除了错误并发送了电子邮件。

但是，它没有正确发送附件。我看到的都是这样的：

代码如下：

Sub Send_Email()

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

'Define Parameters for Email
 Dim s As Object
 Dim db As Object
 Dim body As Object
 Dim bodyChild As Object
 Dim header As Object
 Dim stream As Object
 Dim host As String
 Dim MailDoc As Object

'Define Sheet Parameters

Dim i As Long
Dim j As Long
Dim server, mailfile, user, usersig As String
Dim LastRow As Long, ws As Worksheet
LastRow = Worksheets(1).Range("F" & Rows.Count).End(xlUp).Row  'Finds the last used row

j = 18


'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





With ThisWorkbook.Worksheets(1)

For i = 18 To LastRow



' Create message
Set MailDoc = db.CreateDocument
MailDoc.Form = "Memo"

'Set From
MailDoc.SendTo = Range("Q" & i).value

MailDoc.SentBy = "Food.Specials@Lidl.co.uk"
MailDoc.tmpDisplaySentBy = "Food.Specials@Lidl.co.uk"
MailDoc.FROM = "Food.Specials@Lidl.co.uk"
MailDoc.SendFrom = "Food.Specials@Lidl.co.uk"
MailDoc.Principal = "Food Specials <mailto:Food.Specials@Lidl.co.uk>"

MailDoc.Subject = "Promotion Announcement for week " & Range("I8").value & ", " & Range("T8").value & " - Confirmation required"


'MailDoc.SendTo = Range("Q" & i).value
'Call MailDoc.ReplaceItemValue("CopyTo", "food.specials@lidl.co.uk")

MailDoc.SaveMessageOnSend = True

' Create the body to hold HTML and attachment
Set body = MailDoc.CreateMIMEEntity
'Child mime entity which is going to contain the HTML which we put in the stream
Set bodyChild = body.CreateChildEntity()
Call stream.WriteText(strbody)
Call bodyChild.SetContentFromText(stream, "text/html;charset=iso-8859-1", ENC_NONE)
Call stream.Close
Call stream.Truncate


filename = Range("F" & i).value

'A new child mime entity to hold a file attachment
        Set bodyChild = body.CreateChildEntity()
        Set header = bodyChild.CreateHeader("Content-Type")
        header.SetHeaderVal ("multipart/mixed")

        Set header = bodyChild.CreateHeader("Content-Disposition")
        header.SetHeaderVal ("attachment; filename=" & filename)

        Set header = bodyChild.CreateHeader("Content-ID")

        header.SetHeaderVal (filename)

        Set stream = Session.CreateStream()


        Call bodyChild.SetContentFromBytes(stream, "application/msexcel", ENC_IDENTITY_BINARY) ' All my attachments are excel this would need changing depensding on your attachments.


'Send the email
Call MailDoc.Send(False)

Session.ConvertMime = True ' Restore conversion










    j = j + 1

               Next i
               End With




'Clean Up the Object variables - Recover memory


    Application.CutCopyMode = False


MsgBox "Success!" & vbNewLine & "Announcements have been sent."

End If

End Sub

请谁能告诉我为什么我的 excel 文件没有正确附加？谢谢

Answer 1

你正在尝试Call Object 的一个方法，没有必要这样做。

Call 是一种过时的调用Sub 的方法。它不再是必要的，而且通常会导致细微的运行时错误，应该避免。

变化

Call header.SetHeaderVal("multipart/mixed")

到

header.SetHeaderVal = "multipart/mixed"

应该可以解决问题。如果这可行并且您在下一行获得了 RTE，请对所有不必要的 Call 使用重复该过程。

另外，我不知道 Notes（几年前使用过，从未为它编程过），但是这段代码

Set header = bodyChild.CreateHeader("Content-Type")
Call header.SetHeaderVal("multipart/mixed")
Set header = bodyChild.CreateHeader("Content-Disposition")
Call header.SetHeaderVal("attachment; filename=" & filename)
Set header = bodyChild.CreateHeader("Content-ID")

您不断将相同的变量header 设置为新项目看起来非常可疑。我不完全确定你会如何设置这些，但它看起来不正确。

其他建议：

• 将您的 Dim 语句从使用通用 Object 更改为特定的 Notes.<something> 对象类型。 （除非 Notes 想要一个通用对象 - 我已经很久没有使用过 Notes，也没有为它编程。）
• 删除大量多余的空白行。一些空白有助于将代码直观地分组为逻辑块，但所有额外内容都使其难以阅读。
• 正确缩进您的代码。很难判断IF、With 和For 块在哪里结束，因为它们中的大多数都是左对齐的，但随机位按随机量缩进。
  • 如果您的 If 和 End If 语句排在同一列中，而其中包含的所有内容都缩进（2 或 4 列），则很容易看到该 If 语句中包含的内容。
• 查看Rubberduck - 它会自动为您进行缩进，并为您带来许多其他很酷的技巧和玩具。 （不是作者，而是快乐的用户和无意的 Beta 版测试人员。）

Answer 2

在我看来，您的 MIME 标头的顺序和结构有误。您首先生成 text\html 部分，然后生成 multipart\mixed，然后将 multipart\mixed 的内容设置为 application\msexcel。

multipart\mixed 部分应该是一个容器。它没有自己的内容。它包含两个或多个子部件。

您可能应该在顶层（body 的子级）创建一个 multipart\mixed MIMEEntity，然后创建两个作为 multipart\mixed MIMEEntity 子级的二级子 MIMEEntities：一个具有内容类型 text\html 的子级，第二个是内容类型的应用程序\msexcel。

最好的策略通常是手动发送一条看起来像您希望它出现的方式的消息，然后查看它的 MIME 源并在您的代码中复制它的树结构和顺序。

另外，application\msexcel 内容类型适用于旧式 .xls 文件。您可能想查看this article 以获取最新版本。