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

我正在使用以下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 = "[e-mail]" MailDoc.tmpDisplaySentBy = "[e-mail]" MailDoc.FROM = "[e-mail]" MailDoc.SendFrom = "[e-mail]" MailDoc.Principal = "Food Specials <mailto:[e-mail]>" MailDoc.Subject = "Promotion Announcement for week " & Range("I8").value & ", " & Range("T8").value & " - Confirmation required" 'MailDoc.SendTo = Range("Q" & i).value 'Call MailDoc.ReplaceItemValue("CopyTo", "[e-mail]") 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 

它似乎不想附加任何附件或发送。 我得到一个错误：对象variables或块variables没有设置在这一行：

 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 = "[e-mail]" MailDoc.tmpDisplaySentBy = "[e-mail]" MailDoc.FROM = "[e-mail]" MailDoc.SendFrom = "[e-mail]" MailDoc.Principal = "Food Specials <mailto:[e-mail]>" MailDoc.Subject = "Promotion Announcement for week " & Range("I8").value & ", " & Range("T8").value & " - Confirmation required" 'MailDoc.SendTo = Range("Q" & i).value 'Call MailDoc.ReplaceItemValue("CopyTo", "[e-mail]") 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") 

在那里你不断地设置相同的variablesheader到一个新的项目看起来非常可疑。 我不确定你会如何设定这些，但是这看起来不正确。

其他build议：

• 将使用genericsObject Dim语句更改为特定的Notes.<something>对象types。 （除非Notes需要一个通用的对象 – 我从来没有用过Notes，也没有为它编程。）
• 删除大量多余的空白行。 有些空白很好地帮助将代码可视化地分成逻辑块，但是所有的附加代码使得阅读非常困难。
• 正确缩进你的代码。 要判断IF ， With和For块在哪里结束是非常困难的，因为大部分块是左alignment的，但是随机的位是随机的。
  • 如果If和End If语句在同一列中排列，而其中包含的所有内容都缩进（2或4列），则可以很容易地看到If语句中包含的内容。
• 看看Rubberduck – 它会自动为你进行缩进，同时把很多其他很酷的技巧和玩具带到桌子上。 （不是作者，而是一个快乐的用户和无意的testing者。）

Answer 2

它看起来像你有你的MIME头的顺序和结构错了。 你首先生成一个文本\ html部分，然后是一个多部分\混合，然后你设置多部分\混合为应用程序\ msexcel的内容。

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

您可能应该在顶层创build一个multipart \ mixed MIMEEntity（body的子体），然后创build两个属于multipart \ mixed MIMEEntity的子级的两个二级子MIMEntity：一个带有content-type text \ html的子元素，其次是内容types的应用程序\ msexcel。

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

另外，application \ msexcel content-type是旧式的.xls文件。 你可能想看看这篇文章的更新版本。