Question

VBA-邮件无法发送到smtp服务器

代码如下：

Public r1% 'Sheet1.[a65536].End(xlUp).Row 全部客户的最后行数Public fname$ '主文件的名字Public r2% ' 不重复的全部客户或者选择的名字的最后行数
Sub send()Dim NameSpace$, Email As Object, ns$, n% '形成各个“发送”文件For i = 2 To r2 '按照准备发送的客户数 Set NewBook = Workbooks.Add Sheet1.Range("c1:iv1").Copy NewBook.Worksheets("sheet1").Range("a1") '标题 k = 2 For j = 2 To r1 '遍历所有的记录数 ns = Sheet1.Range("a" & j) '当前客户的名称 If (ns = Sheet2.Range("c" & i)) Then '当前客户的名称就是准备发送的客户 Sheet1.Range("c" & j & ":iv" & j).Copy NewBook.Worksheets("sheet1").Range("a" & k) '只拷贝本客户的信息行 k = k + 1 End If Next j NewBook.SaveAs Filename:=ThisWorkbook.Path & "\" & "发送" & i & ".xls" '用“发送i”保存 NewBook.Close SaveChanges:=True '关闭文件 UserForm5.Show 0 '激活进度条 ' '设置进度条控件 With UserForm5.ProgressBar1 .Min = 1 '设置进度条控件的最小值 .Max = r2 '设置进度条控件的最大值 .Scrolling = 0 End With ''发送准备工作 NameSpace = "http://schemas.microsoft.com/cdo/configuration/" Set Email = CreateObject("CDO.Message") Email.From = Sheet2.Range("g2") & "@qq.com" '发件人邮箱=“辅助工作表”G2 Email.To = Sheet2.Range("d" & i) '要发往的地址=“辅助工作表”D列 Email.Subject = Sheet2.Range("g4") '标题=“辅助工作表”G4 Email.Textbody = Sheet2.Range("c" & i) & " " & Sheet2.Range("g6") '正文=“辅助工作表”C列+G6 Email.AddAttachment ThisWorkbook.Path & "\" & "发送" & i & ".xls" '添加附件 With Email.Configuration.Fields .Item(NameSpace & "smtpusessl") = 1 .Item(NameSpace & "sendusing") = 2 .Item(NameSpace & "smtpserver") = "smtp.qq.com" '发送邮件服务器 .Item(NameSpace & "smtpserverport") = "465" .Item(NameSpace & "smtpauthenticate") = 1 .Item(NameSpace & "sendusername") = Sheet2.Range("g2") & "@qq.com" '发件人邮箱 .Item(NameSpace & "sendpassword") = Sheet2.Range("g3") '发件人邮箱密码 .Update End With Email.send ' '进度条 UserForm5.ProgressBar1.Value = i UserForm5.Caption = Sheet2.Range("c" & i) & "的邮件（含附件）已发送。请稍候!" DoEvents '把控制权交给VBANext iUnload UserForm5MsgBox "文件已经全部发送完成。"For k = 2 To r2 Kill ThisWorkbook.Path & "\" & "发送" & k & ".xls" '删除所有的已经发送的附件Next
If Err.Number <> 0 Then '处理错误 If Err.Number = -2147220977 Then MsgBox "收信人地址 “" & Add & "” 错误! " ElseIf Err.Number = -2147220980 Then MsgBox "错误! 收信人地址未填写" ElseIf Err.Number = -2147220973 Then MsgBox "网络未连接! " Else MsgBox "其他错误!（超时、附件太大、邮箱已满） " End If End End IfEnd Sub
提示的错误：

Answer 1

检查一下qq邮箱，腾讯对于类似的这种发送会有限制的。大约连续发送20封左右会提示你发送过快，限制你的发送。

Answer 2

NameSpace 变量没有赋值，请在定义之后、使用之前赋值，例如：
NameSpace ＝ "http://schemas.microsoft.com/cdo/configuration/"

追问

能否稍做详细解说下。谢谢

追答

.Item(NameSpace & "smtpserverport") = 465