vba调用cdo发送邮件（qq邮箱）

语虚何以言知

最近正好用到这个功能，搜索论坛看到轩辕轼轲老师的帖子代码
Excel通过VBA调用CDO发邮件
http://club.excelhome.net/thread-794521-1-1.html
(出处: ExcelHome技术论坛)


操作系统win10（64bit）+office2016（32bit）
老师的代码后续跟帖反映不能用，主要是时间比较久远，有些设置变了

如果用的是qq邮箱，首先要开授权码

https://service.mail.qq.com/cgi-bin/help?subtype=1&&no=1001256&&id=28


Sub CDOSENDEMAIL()
Dim CDOMail As Variant
On Error Resume Next '出错后继续执行
Application.DisplayAlerts = False '禁用系统提示
ThisWorkbook.ChangeFileAccess Mode:=xlReadOnly '将工作簿设置为只读模式
Set CDOMail = CreateObject("CDO.Message") '创建对象
CDOMail.From = "10000@qq.com" '设置发信人的邮箱
CDOMail.To = "10000@qq.com" '设置收信人的邮箱
CDOMail.Subject = "主题:用CDO发送邮件试验" '设定邮件的主题
'CDOMail.TextBody = "文本内容" '使用文本格式发送邮件
CDOMail.HtmlBody = "当您看到此封邮件，表明CDO设置正确" '使用Html格式发送邮件
CDOMail.AddAttachment ThisWorkbook.FullName '发送本工作簿为附件
stUl = "http://schemas.microsoft.com/cdo/configuration/" '微软服务器网址
With CDOMail.Configuration.Fields
.Item(stUl & "smtpusessl") = True
.Item(stUl & "smtpserver") = "smtp.qq.com" 'SMTP服务器地址
.Item(stUl & "smtpserverport") = 465 'SMTP服务器端口
.Item(stUl & "sendusing") = 2 '发送端口
.Item(stUl & "smtpauthenticate") = 1 '远程服务器需要验证
.Item(stUl & "sendusername") = "10000" '发送方邮箱名称
.Item(stUl & "sendpassword") = 上面连接生成的授权码，非你qq邮箱密码" '发送方邮箱密码
.Item(stUl & "smtpconnectiontimeout") = 60 '连接超时（秒）
.Update
End With
CDOMail.Send '执行发送
Set CDOMail = Nothing '发送成功后即时释放对象
If Err.Number = 0 Then
MsgBox "成功发送邮件", , "温馨提示" '如果没有出错，则提示发送成功
Else
MsgBox Err.Description, vbInformation, "邮件发送失败" '如果出错，则提示错误类型和错误代码
End If
ThisWorkbook.ChangeFileAccess Mode:=xlReadWrite '将工作簿设置为读写模式
Application.DisplayAlerts = True '恢复系统提示
End Sub



红色是在轩辕轼轲代码上按照当下的配置做了微调，调整完毕后亲测可用。

岁月无敌

要求对象怎么处理啊？win7+excel2016

语虚何以言知

岁月无敌 发表于 2019-7-28 10:38
要求对象怎么处理啊？win7+excel2016

cdosys.dll  下载 并注册后再调用试试

ndt3

ThisWorkbook.ChangeFileAccess Mode:=xlReadOnly '将工作簿设置为只读模式
ThisWorkbook.ChangeFileAccess Mode:=xlReadWrite '将工作簿设置为读写模式
这两句适用于对本文件发送，如果穿插有其他sub可能会造成不执行。
我想了个办法绕开了。新建一个新的文件，把需要的工作表复制过去，发送完成删除。测试OK。


代码如下：

Sub CDOSENDEMAIL()
'On Error Resume Next '出错后继续执行
Application.DisplayAlerts = False '禁用系统提示
'ThisWorkbook.ChangeFileAccess Mode:=xlReadOnly '将工作簿设置为只读模式
Set CDOMail = CreateObject("CDO.Message") '创建对象
CDOMail.From = "1234567@qq.com" '设置发信人的邮箱
CDOMail.To = "1234567@qq.com" '设置收信人的邮箱
CDOMail.Subject = "主题:用CDO发送邮件试验" '设定邮件的主题
'CDOMail.TextBody = "文本内容" '使用文本格式发送邮件
CDOMail.HtmlBody = a '使用Html格式发送邮件
CDOMail.AddAttachment ThisWorkbook.Path & "\" & "a" & ".xlsx" '发送当前目录下的工作簿a为附件
stUl = "http://schemas.microsoft.com/cdo/configuration/" '微软服务器网址
With CDOMail.Configuration.Fields
.Item(stUl & "smtpusessl") = True
.Item(stUl & "smtpserver") = "smtp.qq.com" 'SMTP服务器地址
.Item(stUl & "smtpserverport") = 465 'SMTP服务器端口
.Item(stUl & "sendusing") = 2 '发送端口
.Item(stUl & "smtpauthenticate") = 1 '远程服务器需要验证
.Item(stUl & "sendusername") = "1234567" '发送方邮箱名称
.Item(stUl & "sendpassword") = "" '上面连接生成的授权码，非你qq邮箱密码" '发送方邮箱密码
.Item(stUl & "smtpconnectiontimeout") = 60 '连接超时（秒）
.Update
End With
CDOMail.Send '执行发送
Set CDOMail = Nothing '发送成功后即时释放对象
'If Err.Number = 0 Then
'MsgBox "成功发送邮件", , "温馨提示" '如果没有出错，则提示发送成功
'Else
'MsgBox Err.Description, vbInformation, "邮件发送失败" '如果出错，则提示错误类型和错误代码
'End If
'ThisWorkbook.ChangeFileAccess Mode:=xlReadWrite '将工作簿设置为读写模式
Kill ThisWorkbook.Path & "\" & "a" & ".xlsx"'新工作簿删除
'Call dayin
Application.DisplayAlerts = True '恢复系统提示
End Sub

           Sub xjwj()

              Set Wk = Workbooks.Add
                 wd = ThisWorkbook.Name

                 Application.DisplayAlerts = False
                 Wk.SaveAs Filename:=ThisWorkbook.Path & "\" & "a" & ".xlsx" '新建一当前目录下命名为a工作簿
                 Windows(wd).Activate
                 Sheets("邮件").Select
                 Sheets("邮件").Copy Before:=Workbooks(“a"& ".xlsx").Sheets(1)  '全部工作表转移
                  Wk.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Delete '删除工作簿的废工作表  Cells(105536, 3).End(xlUp).row

             Wk.Save
            Wk.Close'新建的工作簿关闭
            Call CDOSENDEMAIL'新建后发送
           End Sub

语虚何以言知

附件发当前工作簿是个特殊的操作，需要加：
ThisWorkbook.ChangeFileAccess Mode:=xlReadOnly '将工作簿设置为只读模式
ThisWorkbook.ChangeFileAccess Mode:=xlReadWrite '将工作簿设置为读写模式

如果发的是非当前工作簿，那么就去掉这两句，然后修改附件那句
CDOMail.AddAttachment ThisWorkbook.FullName '  将红色的修改为文件路径即可

xiaodou19890910

如果是超大附件，怎么办

suxinsen

您好，我使用您的代码，提示发送失败，邮件无法发送到 SMTP 服务器。传输错误代码为 0x80040217邮件无法发送到 SMTP 服务器。传输错误代码为 0x80040217。服务器响应为 not available

游乐缘

感谢分享，学习CDO

星语心愿

有没有办法实现这样的功能：复制当前工作簿的前两张工作表另存为一个工作簿，在工作簿的原名后面加上当前日期，再将该工作簿作为附件调用自己的qq邮箱发送到指定的qq邮箱，邮件名称就是发送的工作簿的名称？

语虚何以言知

星语心愿 发表于 2021-11-30 12:30
有没有办法实现这样的功能：复制当前工作簿的前两张工作表另存为一个工作簿，在工作簿的原名后面加上当前日 ...

试试看,代码没测试,如果有错调试下
先生成邮件附件在制定位置
然后发送该附件

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

复制代码