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

具体 *** 作步骤如下：

1、首先，打开Outlook，点击左上角的“新建”选项。如下图所示，然后进入下一步。

　    

2、其次，在d出窗口中，单击【附加项目】，如下图所示，然后进入下一步。

　    

3、接着，在d出窗口中，找到需要添加的电子邮件标题，选好后点击确定，如下图所示，然后进入下一步。

　    

4、然后，此时，新创建的电子邮件的附件中将包含一个附件，即刚刚保存的电子邮件。

 双击以查看以前的电子邮件内容。 如果需要直接发送，则可以填写收件人并发送，如下图所示，然后进入下一步。

　    

5、随后，如果只想存档电子邮件，则可以右键单击附件并将其另存为。如下图所示，然后进入下一步。

　  

6、接着，单击保存，将d出提示“文件名、目录名或卷标语法不正确”，如下图所示，然后进入下一步。

　    

7、然后，这是因为文件名中有一个冒号，删除该冒号并将其保存即可，如下图所示，然后进入下一步。

　  

8、最后，可以看到附件保存在计算机中了，如下图所示。这样，问题就解决了。

　    

这个很简单,不用excel VBA, 用outlook VBA,编写代码获取某个文件夹里面的邮件对象,然后获取相关信息,之后用createobject创建excel实例,添加新sheet,把得到的邮件信息写入,ok

---