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文件。 您可能希望查看本文以獲取更新的版本。