在客户关系管理过程中，对于客户量很多的业务员来说，一封封的手动发送邮件，效率低、易出错，而且格式规范不统一。如果能批量快速发送邮件，既能保证格式规范，又能让结合系统资源，那就大大解决了业务员的苦恼问题。

单机Excel+Outlook批量发送邮件的VBA，互和科技工程师前期已经介绍过，但是，Excel+Outlook发送邮件，需要本机Outlook客户端支持，有时候并不是太方便。这里就介绍一下利用Excel+CDO进行批量邮件群发的方法。注：CDO是操作系统自带的一种组件功能，全称是cdosys.dll。

要实现Excel+CDO发送邮件，需要以下几个步骤：

1.模版制作；

2.定义名称；（关于如何定义名称，这里不再重复介绍了）

3.设置SMTP邮箱帐号信息；

4.设置VBA代码；

附件部分：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Application.Intersect([附件], Target) Is Nothing Then
    Cancel = False
    Filename = Application.GetOpenFilename
    If Filename = False Then
    Else
        Target = Filename
    End If
End If

End Sub

邮件发送部分：

Sub 发送()
If [邮件主题] = "" Then
lngres = MsgBox("系统检测到邮件主题为空，是否继续发送？", _
vbYesNo + vbDefaultButton2 + vbQuestion, "互和科技")
If lngres = vbNo Then
Cancel = True
Exit Sub
End If
End If

If [邮件内容] = "" Then
lngres = MsgBox("系统检测到邮件内容为空，是否继续发送？", _
vbYesNo + vbDefaultButton2 + vbQuestion, "互和科技")
If lngres = vbNo Then
Cancel = True
Exit Sub
End If
End If

If [SMTP服务器] = "" Then
MsgBox "SMTP服务器未设置，请检查！", 16, "互和科技"
Exit Sub
Else
End If
If [SMTP端口] = "" Then
MsgBox "SMTP端口未设置，请检查！", 16, "互和科技"
Exit Sub
Else
End If
If [账号] = "" Then
MsgBox "发送邮件账号未设置，请检查！", 16, "互和科技"
Exit Sub
Else
End If
If [密码] = "" Then
MsgBox "发送邮件密码未设置，请检查！", 16, "互和科技"
Exit Sub
Else
End If
If [共计] = 0 Then
MsgBox "系统没有发现任何收件人地址，请检查！", 16, "互和科技"
Exit Sub
Else
End If
    Application.DisplayAlerts = False    '禁用系统提示
    'On Error Resume Next                              '出错后继续执行
    'ThisWorkbook.ChangeFileAccess Mode:=xlReadOnly
    Dim myBody As String
    Dim CDOMail As Variant
    Set CDOMail = CreateObject("CDO.Message")     '创建对象
    For Each f In [附件]
        If Cells(f.Row, f.Column) <> "" Then
            CDOMail.AddAttachment Cells(f.Row, f.Column)
        End If
    Next
    CDOMail.From = [账号]          '设置发信人的邮箱
    For Each x In [电子邮件]
        If Cells(x.Row, x.Column) <> "" Then
            CDOMail.To = Cells(x.Row, x.Column)                 '设置收信人的邮箱

            CDOMail.Subject = [邮件主题]    '设定邮件的主题
            CDOMail.HTMLBody = "Dear：" & Cells(x.Row, 4).Text & "
" & "
" & Replace(Replace([邮件内容], Chr(10), "
"), Chr(32), " ")  '发送邮件内容
            STUl = "http://schemas.microsoft.com/cdo/configuration/"    '微软服务器网址
            With CDOMail.Configuration.Fields
                .Item(STUl & "smtpserver") = [SMTP服务器]    'SMTP服务器地址
                .Item(STUl & "smtpserverport") = [SMTP端口]       'SMTP服务器端口
                .Item(STUl & "sendusing") = 2             '发送端口
                .Item(STUl & "smtpauthenticate") = 1      '远程服务器需要验证
                .Item(STUl & "sendusername") = [账号]   '发送方邮箱名称
                .Item(STUl & "sendpassword") = [密码]    '发送方邮箱密码
                .Item(STUl & "smtpconnectiontimeout") = 30    '连接超时（秒）
                .Update
            End With
            CDOMail.Send                                  '执行发送
        End If
    Next
    Set CDOMail = Nothing                             '发送成功后即时释放对象
    If Err.Number = 0 Then
        MsgBox "共成功发送" & [共计] & "封邮件！", 64, "互和科技"           '如果没有出错，则提示发送成功

           Dim obj As Object
           Set obj = Application.COMAddIns.Item("prjAddin.Office_Addin").Object
           obj.SaveReport
           Set obj = Nothing
    Else
        MsgBox Err.Description, vbInformation, "发送失败"    '如果出错，则提示错误类型和错误代码
    End If
    'ThisWorkbook.ChangeFileAccess Mode:=xlReadWrite
    Application.DisplayAlerts = True    '恢复系统提示
End Sub

最终发送成功后的效果；

本文由互和科技·通用Excel官网原创，转载请注明。