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

本帖最后由 ndt3 于 2019-11-21 21:25 编辑

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