OFFICE2010 自动发送邮件延时的问题

qq270850428 · 发表于 2012-3-13 09:18

Sub 对帐单发送()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim cancelsend As Long
Dim i As Integer
For i = 5 To Sheets("通讯录").[A65536].End(xlUp).Row
      Set OutApp = CreateObject("Outlook.Application")
      OutApp.Session.Logon
      Set OutMail = OutApp.CreateItem(0)
      'strbody = "您好!请及时查看贵公司对账单"       '邮件内容
      On Error Resume Next
      With OutMail
         .To = Sheets("通讯录").Range("C" & i).Value '邮件地址
         .CC = ""
         .BCC = ""
         .subject = "[" & Sheets("通讯录").Cells(i, 2).Value & "]" & Sheets("通讯录").Cells(1, 2).Value  '邮件主题
         .Body = Sheets("通讯录").Cells(2, 2).Value ' strbody '邮件内容
               'If Sheets("通讯录").Cells(i, 4).Value <> "" Then
         .Attachments.Add "E:\对账单\" & Sheets("通讯录").Cells(i, 3).Value & Sheets("通讯录").Cells(i, 2).Value & ".xls" '邮件附件存放目录(附加文件)
         .Attachments.Add "E:\对账单\" & Sheets("通讯录").Cells(i, 2).Value & Sheets("通讯录").Cells(i, 3).Value & ".xls" '邮件附件存放目录(附加文件)
                     'End If
         If OutMail.Attachments.Count <> 0 Then
         'cancelsend = MsgBox("  是否忘记粘贴附件了！" & vbNewLine & vbNewLine & "    确定要发送吗?", _
         vbYesNo + vbDefaultButton2 + vbQuestion, "忘记粘贴附件提示")
         ' If cancelsend = vbNo Then Cancel = True
         ' Else:
         .Send
         End If

      End With
      On Error GoTo 0
      Set OutMail = Nothing
      Set OutApp = Nothing
Next i
End Sub

大侠们：我用的是上面的代码来自动发送邮件，但最近出现了问题，因为对方客户好多是QQ邮箱，好多邮件自动退回，没有发送成功。是短时间内发送大量邮件，会认识是邮件攻击或垃圾邮件，我想设置成延时发送，查了相关资料说mailitem...deferreddeliverytime 好用，但我不知道如何该句用法，请朋友帮忙，急，谢谢

qq270850428 · 发表于 2012-3-13 09:52

哥们，好象不行啊，我的意思是想让每个邮件的发送相间隔一定时间，而且刚也没反映

dsd999 · 发表于 2012-3-13 09:30

dteThen = dateadd("n", 15, Now)
Mail.DeferredDeliveryTime = dteThen

这是延迟15分钟发送。

qq270850428 · 发表于 2012-3-13 09:35

十分感谢，我试试，我把这句放在send后面吗

qq270850428 · 发表于 2012-3-13 10:23

我把延时的时间设为一个变量，然后就改成每个延后时间了，哈哈，谢谢

dsd999 · 发表于 2012-3-13 10:23

那句写在send之前。

现在邮件应该都在发件箱吧。

dsd999 · 发表于 2012-3-13 10:47

你要先了解qq对什么频率的邮件会被退信？

还被退肯定是间隔太短了。

qq270850428 · 发表于 2012-3-13 10:42

还是不行呀，发了一百多封，还是退回来好多邮件，这可咋办呀

qq270850428 · 发表于 2012-3-13 11:27

我改成了这样，帮我看下是不是写错了，实际中没有延时
Sub 对帐单发送()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim cancelsend As Long
Dim i, ys As Integer
For i = 5 To Sheets("通讯录").[A65536].End(xlUp).Row
      ys = 1
      Set OutApp = CreateObject("Outlook.Application")
      OutApp.Session.Logon
      Set OutMail = OutApp.CreateItem(0)
      'strbody = "您好!请及时查看贵公司对账单，如有疑义请与我核对"       '邮件内容
      On Error Resume Next
      With OutMail
         .To = Sheets("通讯录").Range("C" & i).Value '邮件地址
         .CC = ""
         .BCC = ""
         .subject = "[" & Sheets("通讯录").Cells(i, 2).Value & "]" & Sheets("通讯录").Cells(1, 2).Value  '邮件主题
         .Body = Sheets("通讯录").Cells(2, 2).Value ' strbody '邮件内容
               'If Sheets("通讯录").Cells(i, 4).Value <> "" Then
         .Attachments.Add "D:\对账单\" & Sheets("通讯录").Cells(i, 3).Value & Sheets("通讯录").Cells(i, 2).Value & ".xls" '邮件附件存放目录(附加文件)
         .Attachments.Add "D:\对账单\" & Sheets("通讯录").Cells(i, 2).Value & Sheets("通讯录").Cells(i, 3).Value & ".xls" '邮件附件存放目录(附加文件)
                     'End If
         If OutMail.Attachments.Count <> 0 Then
         'cancelsend = MsgBox("  是否忘记粘贴附件了！" & vbNewLine & vbNewLine & "    确定要发送吗?", _
         vbYesNo + vbDefaultButton2 + vbQuestion, "忘记粘贴附件提示")
         ' If cancelsend = vbNo Then Cancel = True
         ' Else:
         dteThen = DateAdd("n", ys, Now)
         OutMail.DeferredDeliveryTime = dteThen
         .Send

         End If

      End With
      On Error GoTo 0
      Set OutMail = Nothing
      Set OutApp = Nothing
      ys = ys + 2
Next i
End Sub

dsd999 · 发表于 2012-3-13 11:34

本帖最后由 dsd999 于 2012-3-13 11:34 编辑

代码没问题。

Sub 对帐单发送()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim cancelsend As Long
Dim i, ys As Integer

      ys = 5
      Set OutApp = CreateObject("Outlook.Application")
      OutApp.session.Logon
      Set OutMail = OutApp.CreateItem(0)
      'strbody = "ÄúºÃ!Çë¼°Ê±²é¿´¹ó¹«Ë¾¶ÔÕËµ¥£¬ÈçÓÐÒÉÒåÇëÓëÎÒºË¶Ô"       'ÓÊ¼þÄÚÈÝ
      On Error Resume Next
      With OutMail
         .To = "***@sohu.com"
         .CC = ""
         .BCC = ""
         .Subject = "aa"
         .Body = "bb"
               'If Sheets("Í¨Ñ¶Â¼").Cells(i, 4).Value <> "" Then
                     'End If

         dteThen = DateAdd("n", ys, Now)
         OutMail.DeferredDeliveryTime = dteThen
         .Send


      End With
      On Error GoTo 0
      Set OutMail = Nothing
      Set OutApp = Nothing


End Sub

		自动登录	找回密码
密码			免费注册

[求助] OFFICE2010 自动发送邮件延时的问题