[已解决]vba发送邮件报错

Saint_Zuo

我把代码中的发件人改成自己的qq邮件，密码改为自己的qq密码，错误提示如附件中sheet1的截图所示，请教是什么原因？

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-9-15 14:56

1. Sub CDOSENDEMAIL()
   
2. 
   
3.     Dim CDOMail As Object
   
4.     Dim STUl As String
   
5. 
   
6.     On Error Resume Next    '出错后继续执行
   
7.     Application.DisplayAlerts = False    '禁用系统提示
   
8.    
   
9.     STUl = "http://schemas.microsoft.com/cdo/configuration/"    '微软服务器网址
   
10.     'ThisWorkbook.ChangeFileAccess Mode:=xlReadOnly    '将工作簿设置为只读模式
    
11.    
    
12.     Set CDOMail = CreateObject("CDO.Message")    '创建对象
    
13.     With CDOMail
    
14.         .From = "163728@qq.com"    '设置发信人的邮箱
    
15.         .To = "163728@qq.com"    '设置收信人的邮箱
    
16.         .Subject = "主题:用CDO发送邮件试验，时间是：" & Format(Now, "YYYY-MM-DD mm:hh:ss")    '设定邮件的主题
    
17.         '.TextBody = "文本内容" '使用文本格式发送邮件
    
18.         .HtmlBody = "当您看到此封邮件，表明CDO设置正确"    '使用Html格式发送邮件
    
19.         '.AddAttachment ThisWorkbook.FullName    '发送本工作簿为附件
    
20.         
    
21. 
    
22.         With .Configuration.Fields
    
23.             .Item(STUl & "smtpserver") = "smtp.qq.com"    'SMTP服务器地址
    
24.             .Item(STUl & "smtpserverport") = 25    'SMTP服务器端口
    
25.             .Item(STUl & "sendusing") = 2    '发送端口
    
26.             .Item(STUl & "smtpauthenticate") = 1    '远程服务器需要验证
    
27.             .Item(STUl & "sendusername") = "163728@qq.com"    '发送方邮箱名称
    
28.             .Item(STUl & "sendpassword") = ""    '发送方邮箱密码
    
29.             .Item(STUl & "smtpconnectiontimeout") = 60    '连接超时（秒）
    
30.             .Update
    
31.         End With
    
32. 
    
33.         .Send    '执行发送
    
34.     End With
    
35. 
    
36.     Set CDOMail = Nothing    '发送成功后即时释放对象
    
37.     If Err.Number = 0 Then
    
38.         MsgBox "成功发送邮件", , "温馨提示"    '如果没有出错，则提示发送成功
    
39.     Else
    
40.         MsgBox Err.Description, vbInformation, "邮件发送失败"    '如果出错，则提示错误类型和错误代码
    
41.     End If
    
42.     'ThisWorkbook.ChangeFileAccess Mode:=xlReadWrite    '将工作簿设置为读写模式
    
43.     Application.DisplayAlerts = True    '恢复系统提示
    
44. End Sub

复制代码

重新整理下，测式没问题了，你只要把发信人都换成你的邮箱，收信人改下，再填上密码就可以了。

跳转到最佳答案楼层

hwc2ycy

连接不了服务器。
你换个别的邮箱地址试试（非企鹅的）

hwc2ycy

Sub 邮件发送()
    Dim cm As New CDO.Message

    On Error GoTo ErrorHandler
         
    Set cm = CreateObject("CDO.Message")    '创建对象 '引用路径：C:\Windows\system32\cdosys.dll
    cm.From = "1234567@qq.com"    '设置发信人的邮箱"
    cm.To = "649725266@qq.com,excelpx@163.com"    '设置收信人的邮箱
    cm.Subject = "主题:邮件发送试验"    '设定邮件的主题
    'cm.TextBody =  '邮件正文，使用文本格式发送邮件
    cm.HtmlBody = "邮件发送试验^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^"    '使用html格式发送邮件
    cm.AddAttachment ThisWorkbook.Path & "/a.xls"
    STUl = "http://schemas.microsoft.com/cdo/configuration/"    '微软服务器网址
    With cm.Configuration.Fields
        .Item(STUl & "smtpserver") = "smtp.qq.com"         'SMTP服务器地址
        .Item(STUl & "smtpserverport") = 25                  'SMTP服务器端口
        .Item(STUl & "sendusing") = 2                        '发送端口
        .Item(STUl & "smtpauthenticate") = 1      '需要提供用户名和密码，0是不提供           '
        .Item(STUl & "sendusername") = "1234567"                '发送方邮箱名称
        .Item(STUl & "sendpassword") = "12345671"                  '发送方邮箱密码
        .Update
    End With
    cm.Send    '最后当然是执行发送了
    Set cm = Nothing
    '发送成功后即时释放对象
    Exit Sub
   
ErrorHandler:
    MsgBox Err.Number & vbCrLf & Err.Description
End Sub

加上红字的，有利于看报错的提示。

hwc2ycy

提供个论坛轩辕轼轲老师的代码

1. Sub CDOSENDEMAIL()
   
2. 
   
3.     Dim CDOMail As Variant
   
4. 
   
5.     On Error Resume Next    '出错后继续执行
   
6. 
   
7.     Application.DisplayAlerts = False    '禁用系统提示
   
8. 
   
9.     ThisWorkbook.ChangeFileAccess Mode:=xlReadOnly    '将工作簿设置为只读模式
   
10. 
    
11.     Set CDOMail = CreateObject("CDO.Message")    '创建对象
    
12. 
    
13.     CDOMail.From = "10000@qq.com"    '设置发信人的邮箱
    
14. 
    
15.     CDOMail.To = "10000@qq.com"    '设置收信人的邮箱
    
16. 
    
17.     CDOMail.Subject = "主题:用CDO发送邮件试验"    '设定邮件的主题
    
18. 
    
19.     'CDOMail.TextBody = "文本内容" '使用文本格式发送邮件
    
20. 
    
21.     CDOMail.HtmlBody = "当您看到此封邮件，表明CDO设置正确"    '使用Html格式发送邮件
    
22. 
    
23.     CDOMail.AddAttachment ThisWorkbook.FullName    '发送本工作簿为附件
    
24. 
    
25.     STUl = "http://schemas.microsoft.com/cdo/configuration/"    '微软服务器网址
    
26. 
    
27.     With CDOMail.Configuration.Fields
    
28. 
    
29.         .Item(STUl & "smtpserver") = "smtp.qq.com"    'SMTP服务器地址
    
30. 
    
31.         .Item(STUl & "smtpserverport") = 25    'SMTP服务器端口
    
32. 
    
33.         .Item(STUl & "sendusing") = 2    '发送端口
    
34. 
    
35.         .Item(STUl & "smtpauthenticate") = 1    '远程服务器需要验证
    
36. 
    
37.         .Item(STUl & "sendusername") = "10000"    '发送方邮箱名称
    
38. 
    
39.         .Item(STUl & "sendpassword") = "password"    '发送方邮箱密码
    
40. 
    
41.         .Item(STUl & "smtpconnectiontimeout") = 60    '连接超时（秒）
    
42. 
    
43.         .Update
    
44. 
    
45.     End With
    
46. 
    
47.     CDOMail.Send    '执行发送
    
48. 
    
49.     Set CDOMail = Nothing    '发送成功后即时释放对象
    
50. 
    
51.     If Err.Number = 0 Then
    
52. 
    
53.         MsgBox "成功发送邮件", , "温馨提示"    '如果没有出错，则提示发送成功
    
54. 
    
55.     Else
    
56. 
    
57.         MsgBox Err.Description, vbInformation, "邮件发送失败"    '如果出错，则提示错误类型和错误代码
    
58. 
    
59.     End If
    
60. 
    
61.     ThisWorkbook.ChangeFileAccess Mode:=xlReadWrite    '将工作簿设置为读写模式
    
62. 
    
63.     Application.DisplayAlerts = True    '恢复系统提示
    
64. 
    
65. End Sub

复制代码

zjdh

关键是你的QQ邮箱是否设置了！

Saint_Zuo

hwc2ycy 发表于 2013-9-15 09:29
提供个论坛轩辕轼轲老师的代码

谢谢了，我用了您提供的代码，还是提示“与服务器的传输连接失败。”

Saint_Zuo

zjdh 发表于 2013-9-15 09:29
关键是你的QQ邮箱是否设置了！

我设置过了，还是不行呀！

hwc2ycy

你换个别的邮箱地址，不用企鹅的试试。
我之前测的时候说是拒收。
你用163,SINA的试试。

hwc2ycy

对了，你改了上面的发信人的资料没？那也是要改的。
CDOMail.From =  '设置发信人的邮箱"

zjdh

Saint_Zuo 发表于 2013-9-15 13:21
我设置过了，还是不行呀！

我刚才用你的宏发了几个邮件，全都成功啦！