outlook vba发邮件问题

仔细看了一下，原来的代码的确有些问题，这个是我现在用的，我一次只能发不超过15封邮件，否则邮件网关（单位自有邮件服务器）会阻止我。延迟发送是我加的，没有测试。

我下面的代码是在如下情况下使用（很有必要说清楚）。

就我自用来说。

首先，我有一个excel文件，其中存放的是的待发送人员的姓名以及邮件地址。

其次，我会将网络断开，使用word的邮件功能，并使用上述excel中的邮件地址，合并，并批量生成邮件。

之后，因为网络断开，本来要通过outlook发送的邮件，都会因为发送失败出现在发件箱中。出于方便 *** 作和手动控制发送节奏的目的，将发件箱中所有发送失败的邮件拷贝到草稿箱。

最后，重新连接网络，使用上述代码手动一次发个10封左右的邮件，我是发一次歇一会。发送邮件通过vba添加附件。（你所要求的延迟，是我临时加的，没有经过测试）如果加了延迟，你可以修改vba中，一次复制到发件箱邮件的个数，控制时间间隔。（也可以一次复制完毕，我出于测试的目的，第一次通常会用程序从草稿箱移动2个邮件发送，然后检查看有无错误，以免错误过大难以控制）

希望对你有帮助，附现在用的代码。

Option Explicit

'将草稿箱中的邮件发送出去

Const strAttachmentPath = "" '附件路径E:\办公\科研处\国家基金要点提示\2014自然基金模板及简明指南摘要.rar

Const intMailCount = 10 '单次发送邮件数

Sub subSendEmail()

'On Error Resume Next

Dim fld_OutBox AsOutlook.MAPIFolder

Dim objItemsAs Outlook.Items

Dim myItem As Object

Dim myItems() As Object

Dim iIndex As Integer '延迟技术器

Dim intervalMinute As Integer '延迟分钟数

Dim objMail As Outlook.MailItem

iIndex = 1

Dim n As Integer

If MsgBox("附件:" &strAttachmentPath &vbCrLf &"单次发送邮件数:" &intMailCount &vbCrLf &"以上信息正确与否？", vbOKCancel) <>vbOK Then

Exit Sub

End If

'获得发件箱

Set fld_OutBox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderOutbox)

Set objItems = fld_OutBox.Items

If fld_OutBox.Items.Count = 0 Then

'如果发件箱邮件数为0从草稿箱中移动邮件

'从草稿箱中移动若干邮件到发件箱

funMoveMailToOutBox intMailCount

End If

'如果发件箱存在对象，对其中的邮件执行发送

If objItems.Count >0 Then

For Each objMail In objItems

If (objMail.Class = 43) Then

'发送邮件

If (strAttachmentPath <>"") Then

'存在附件路径,添加附件

objMail.Attachments.AddTrim(strAttachmentPath), olByValue, 1

End If

'延迟发送

'iIndex = iIndex + 1

'objMail.DeferredDeliveryTime =DateAdd("n", iIndex * intervalMinute, Now)

objMail.Send

End If

Next

End If

End Sub

Function funMoveMailToOutBox(ByVal numEmailAs Integer) As Boolean

'移动numEmail指定的邮件数从draft到outBox

'On Error Resume Next

Dim fld_OutBox AsOutlook.MAPIFolder

Dim fld_DraftsAsOutlook.MAPIFolder

Dim objItemsDrafts AsOutlook.Items

Dim objMail As Outlook.MailItem

Dim n As Integer

n= 0

'获得发件箱对象

Set fld_OutBox =Application.GetNamespace("MAPI").GetDefaultFolder(olFolderOutbox)

'获得草稿箱对象

Set fld_Drafts =Application.GetNamespace("MAPI").GetDefaultFolder(olFolderDrafts)

Set objItemsDrafts = fld_Drafts.Items

'按照numEmail指定的数值移动邮件

While (objItemsDrafts.Count >0) And (n <numEmail)

'如果草稿箱不为空

Set fld_Drafts =Application.GetNamespace("MAPI").GetDefaultFolder(olFolderDrafts)

Set objItemsDrafts = fld_Drafts.Items

Set objMail = objItemsDrafts.GetFirst()

If (objMail.Class = 43) Then

objMail.Move fld_OutBox

Else

Exit Function

End If

n = n + 1

Wend

End Function

Excel不是编程语言，内嵌的VBA有编程功能，可以扩展Excel的应用。Excel也确实内嵌了邮件收发的功能，但添加的附件一般都是当前工作表或工作簿。

SendMail 方法

使用已安装的邮件系统发送工作簿。

expression.SendMail(Recipients, Subject, ReturnReceipt)

expression 必需。该表达式返回一个 Workbook 对象。

Recipients Variant 类型，必需。以文本形式指定收件人的名称，如果有多个收件人，则使用文本字符串数组。必须至少指定一个收件人，而且所有收件人名单都添加到“收件人”中。

Subject Variant 类型，可选。指定消息的主题。如果省略该参数，则使用文档名称。

ReturnReceipt Variant 类型，可选。如果该值为 True，则要求返回回执；如果该值为 False，则不要求返回回执。默认值为 False。

示例

本示例将当前活动工作簿传送给一个收件人。

ActiveWorkbook.SendMail recipients:="Jean Selva"

---