批量发送邮件，Excel VBA 批量发邮件，无需 Outlook

云衔科技是一家专注于数字化营销解决方案和SaaS软件服务的领先企业。公司凭借深厚的行业经验和专业技术能力，致力于为企业客户提供全方位、高效的数字广告代理与运营服务，以及定制化的SaaS软件解决方案。 Excel ...

云衔科技是一家专注于数字化营销解决方案和SaaS软件服务的领先企业。公司凭借深厚的行业经验和专业技术能力，致力于为企业客户提供全方位、高效的数字广告代理与运营服务，以及定制化的SaaS软件解决方案。

Excel VBA 可以调用 批量发送邮件，但有个缺点就是要求安装 并配置好客户端。对于购买的笔记本电脑一般预装的都是家庭版 ，并不包含 组件。为了批量发邮件而去安装不需要的 ，实在是没有必要。

正好最近工作上需要批量发送邮件，使用 VBA 调用系统自带的 CDO 接口实现了纯 Excel 批量发送邮件。

实现方法：

1、把工作簿和附件放在同一个目录下，在“发件箱”工作表按要求设置。

2、设计好要发送的模版。

3、“明细”是要发送的内容，VBA 按照收件人邮箱将记录分别写入模版中，循环执行发送，每条记录一封邮件。

4、按下“发送邮件”按钮确认是否发送。

5、开始发送，在状态栏显示邮件发送状态。

6、显示发送完成情况。

VBA 代码如下：

Option ExplicitSub CDOMail()    Dim tt As Single    tt = Timer    Dim CDOMail As Object    Dim strPath, flag As String    Dim i, r, c, j, g As Long    Dim strURL As String    Dim strFromMail As String    Dim strFromName As String    Dim strPassWord As String    Dim number As String    Dim name As String    Dim title As String    Dim addfile As String    g = 0    title = Sheets("发件箱").Range("b5").Value    '“发件箱”表中标题信息赋值给变量    strPath = ThisWorkbook.Path & Application.PathSeparator    '获取当前工作簿所在的路径（附件路径）    strFromMail = Sheets("发件箱").Range("b2").Value    '发件人邮箱地址赋值给变量    strFromName = Sheets("发件箱").Range("b3").Value    '发件人邮箱名称赋值给变量    addfile = Sheets("发件箱").Range("b7").Value    'c = Application.CountA(Sheets("模版").Range("a3:z3"))    c = Application.CountA(Sheets("模版").Range("3:3"))    '计算第三行非空单元格(表头列数）    r = Sheets("明细").Cells(Rows.Count, 2).End(3).Row    '按照“明细”表第二列（收件人邮箱）计算行数    Sheets("明细").Range("a2:a10000").ClearContents    '清除此区域的值    If strFromMail = "" Or strFromName = "" Then        MsgBox "未输入邮箱地址或名称。"        Exit Sub    End If    strPassWord = Sheets("发件箱").Range("b4").Value    If strPassWord = "****" Or strPassWord = "" Then        MsgBox "未输入邮箱密码"        Exit Sub    End If    With Application        .ScreenUpdating = False        '禁用屏幕更新        .DisplayAlerts = False        '禁用警告    End With    Sheets("明细").Select    '选择“明细”表    flag = MsgBox("确定要发送邮件吗？", vbYesNo)    '获取“是”或“否”的值，赋值给变量。    If flag = vbNo Then Exit Sub    '如果选择“否”则退出程序。    On Error Resume Next    '忽略错误继续执行    tt = Timer    Application.DisplayStatusBar = True    '开启状态栏显示    For i = 2 To r        '按照明细表的记录行数'        Application.StatusBar = "开始发送第 " & i - 1 & " 封邮件,共 " & r - 1 & " 封。"        '在状态栏显示发送情况        number = Sheets("明细").Cells(i, 3).Value        '员工号赋值给变量        name = Sheets("明细").Cells(i, 2).Value        '员工姓名赋值给变量        Sheets("明细").Range(Cells(i, 2), Cells(i, c + 1)).Copy Sheets("模版").Cells(4, 1)        '复制一条记录到“模版”表        Sheets("模版").Select        '选择“模版”表        Sheets("模版").Copy        '复制工作表        ActiveWorkbook.SaveAs Filename:=strPath & "安全提醒" & ".xls", FileFormat:=xlExcel8        '在当前路径另存为“模版.xls”文件        ActiveWorkbook.Close SaveChanges:=False        '关闭工作簿不提示保存        Set CDOMail = CreateObject("CDO.Message")        '--------创建CDO对象        CDOMail.From = strFromMail        '--------发信人的邮箱        CDOMail.To = Sheets("明细").Cells(i, 2)        '--------收信人的邮箱        CDOMail.Subject = name & "_" & title        '--------邮件的主题        CDOMail.HTMLBody = Sheets("发件箱").Range("b6").Value _        & "
" & "该邮件使用 Excel VBA 批量发送" _        & "
" & "信息技术部" & "
" & Date        '--------邮件的内容（Html格式)        'CDOMail.TextBody =        '--------邮件的内容（文本格式)        CDOMail.AddAttachment strPath & "安全提醒" & ".xls"        CDOMail.AddAttachment strPath & addfile        '--------邮件的附件        strURL = "http://schemas.microsoft.com/cdo/configuration/"        '--------微软服务器网址        With CDOMail.Configuration.Fields            .Item(strURL & "smtpserver") = "smtp.263.net"            '--------SMTP服务器地址            .Item(strURL & "smtpserverport") = 25            '--------SMTP服务器端口            .Item(strURL & "sendusing") = 2            '--------发送端口            .Item(strURL & "smtpauthenticate") = 1            '--------远程服务器验证            .Item(strURL & "sendusername") = strFromName            '--------发送方邮箱名称            .Item(strURL & "sendpassword") = strPassWord            '--------发送方smtp密码            .Item(strURL & "smtpconnectiontimeout") = 60            '--------设置连接超时（秒）            .Update        End With        CDOMail.Send        '--------发送        Sheets("明细").Select        If Err.number = 0 Then            Cells(i, 1) = "发送成功"            '没有错误则在单元格中写入“发送成功”            g = g + 1            '计算发送成功的次数        Else            Cells(i, 1) = "发送失败"            '发生错误则在单元格中写入“发送失败”            'cells(i, 1) = Err.Description            '将错误信息写入单元格            'MsgBox Err.Description, vbInformation, "邮件发送失败"            Err.Clear            '清除错误        End If        Kill strPath & "安全提醒" & ".xls"        '删除文件        Application.StatusBar = "已发送 " & i - 1 & " 封邮件，共 " _        & r - 1 & " 封，进度 " _        & Format((i - 1) / (r - 1), "0%") & "，用时 " _        & Format((Timer - tt), "0.00") & " 秒，共需约 " _        & Format((Timer - tt) / ((i - 1) / (r - 1)), "0.00") _        & " 秒，" & "倒计时 " _        & Format((Timer - tt) / ((i - 1) / (r - 1)) - (Timer - tt), "0.00") _        & " 秒，请稍候……"        '状态栏显示发送信息    Next    Set CDOMail = Nothing    '释放对象    With Application        .ScreenUpdating = True        '启用屏幕更新        .DisplayAlerts = True        '启用警告    End With    Sheets("明细").Cells(1, 1).Select    '切换定位到“明细”表 A1 单元格    Application.StatusBar = False    '禁用状态栏显示    MsgBox "完成发送任务！总共用时：" _    & Format(Timer - tt, "0.00") _    & " 秒！成功发送 " & g & " 封，失败 " _    & r - 1 - g & " 封。"    '弹窗显示完成情况End Sub