1
我正在使用以下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 = "[email protected]"
MailDoc.tmpDisplaySentBy = "[email protected]"
MailDoc.FROM = "[email protected]"
MailDoc.SendFrom = "[email protected]"
MailDoc.Principal = "Food Specials <mailto:[email protected]>"
MailDoc.Subject = "Promotion Announcement for week " & Range("I8").value & ", " & Range("T8").value & " - Confirmation required"
'MailDoc.SendTo = Range("Q" & i).value
'Call MailDoc.ReplaceItemValue("CopyTo", "[email protected]")
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 = "[email protected]"
MailDoc.tmpDisplaySentBy = "[email protected]"
MailDoc.FROM = "[email protected]"
MailDoc.SendFrom = "[email protected]"
MailDoc.Principal = "Food Specials <mailto:[email protected]>"
MailDoc.Subject = "Promotion Announcement for week " & Range("I8").value & ", " & Range("T8").value & " - Confirmation required"
'MailDoc.SendTo = Range("Q" & i).value
'Call MailDoc.ReplaceItemValue("CopyTo", "[email protected]")
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文件没有正确安装？谢谢
好的，谢谢我设法让代码工作（种）。没有更多的错误，但我的Excel文件没有正确附加。请参阅EDIT2 – user7415328
我将假定您的附件未附加，因为您没有正确分配它。您需要消除“Call”的所有不当使用。我挑选了最初的几个 - 你将不得不追捕其余的。 *我认为VBA中没有任何'Call'的正确用法。这是一个过时的功能，留在规范中，以防止古代码破坏Office产品的新版本。 – FreeMan