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部分应该是一个容器。 它没有自己的内容。 它包含两个或多个子部件。

您可能应该在顶层创建一个multipart \\ mixed MIMEEntity（body的子级），然后创建两个二级子MIMEEntities，它们是multipart \\ mixed MIMEEntity的子级：一个内容类型为text \\ html的子级，以及第二个是内容类型application \\ msexcel。

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

此外，application \\ msexcel content-type适用于旧式.xls文件。 您可能希望查看本文以获取更新的版本。