Question

outlook vba发邮件问题

您好！我看了您回复“如何使用VBA调用outlook发送邮件源码”
百度知道网址是：http://zhidao.baidu.com/link?url=umMJh8FClwjqfh-aNgjlnzLB3s3-JXjkz7Sz4la_yT6eGcrLdtdFtjISvt0UopjjucUp8V2e07CRL-ad2HdLd_
请原谅我是初学者，我用的是office 2010 ，在代码中我发现一些不明白的地方，请您帮忙解决一下：

1，“Set fld_OutBox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderOutbox)” 这里的“GetDefaultFolder”无论实际运行还是在MSDN帮助里面，都说不能调用“olFolderOutbox” 。简单说就是不能调用发件箱里面的草稿，只能调用草稿箱里面的，所以我就换了“olFolderDrafts”。请问您能解决用发件箱发的功能吗？

2，代码中”从草稿箱中移动若干邮件到发件箱“，”funMoveMailToOutBox 15“ ，有点不完整，可以处理下吗？

3，我一般一发就有上百封邮件，如果一下子发出去会被误认为是垃圾邮件，请问可以实现每封邮件间，间隔2分钟的功能吗？

不胜感激！

Answer 1

仔细看了一下，原来的代码的确有些问题，这个是我现在用的，我一次只能发不超过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 objItems As 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_Drafts AsOutlook.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

Answer 2

关于问题1、2，发件箱里面的草稿不能调用的话，可以把html源代码找到，然后写进VBA代码中。

关于问题3，使用这个VBA语句，可以延时2分钟
Application.Wait Now + TimeValue("00:02:00")

Answer 3

要实现稳定间隔，至少用VB吧。。。。