跟我来！ 一步一步教你批量发送邮件

闻启学

刚才论坛看到这个帖子
excel vba 批量发送邮件邮件内容放入表格指定主题
http://club.excelhome.net/thread-1294317-1-1.html
(出处: ExcelHome技术论坛)

这个是用CDO 发送邮件的  ，现在用CDO发送  是有Bug的  有时候时候不能发送的  请大家注意

大家也可以参考下

13671337687

闻老师，如何添加附件啊

闻启学

13671337687 发表于 2020-1-15 16:50
闻老师，如何添加附件啊

第一楼 有写明 添加附件  认真看下注释

闻启学

winlandfs 发表于 2018-10-12 17:16
请教，
1.发件人可否是系统发出而不是个人？
2.是否可套用outlook的签名？因为现在这样发出的邮件都没有 ...

1,不明什么意思 。2 这个肯定可以的的

renkangjizhen

感谢闻学委分享！

renkangjizhen

很实用的课题！感谢楼主分享！

fengyuelele

学习了，点赞

lmy58447830

您好，请问下，我用这个VBA run完之后提示发送了3封邮件，但是我的收件箱没有邮件，发件箱也没有，请问下是什么问题呢？

闻启学

lmy58447830 发表于 2020-4-27 17:32
您好，请问下，我用这个VBA run完之后提示发送了3封邮件，但是我的收件箱没有邮件，发件箱也没有，请问下是 ...

邮箱地址正确  ？？

lmy58447830

闻启学 发表于 2020-4-29 14:06
邮箱地址正确  ？？

闻老师，您好！

邮箱地址都是正确的。经过多次测试，邮件能发出来了。可是附件带不出了，不知道原因是什么？



'*******************************************************************'

'程序名称：最完美的利用EXCEL自动批量发送邮件

'
'经测试在OUTLOOK 2000中不会显示警告窗口.

'引用：Microseft Outlook *.0 Object Library

'需要注意一点 , 邮件的标题, 否则不能自动放送!

'**********************************************************************

Sub 批量发送邮件()

'要能正确发送并需要对Microseft Outlook进行有效配置

    On Error Resume Next

    Dim rowCount, endRowNo

    '要正常运行下面这句,要将工具/引用中的Microseft Outlook *.0 Object Library(其中*为你Microseft Outlook的版本号)选上

    Dim objOutlook As New Outlook.Application

    Dim objMail As MailItem

    '取得当前工作表与Cells(1,1)相连的数据区行数

    endRowNo = Cells(1, 1).CurrentRegion.Rows.Count

    '创建objOutlook为Outlook应用程序对象

    Set objOutlook = New Outlook.Application

    '开始循环发送电子邮件

    For rowCount = 2 To endRowNo

        '创建objMail为一个邮件对象

        Set objMail = objOutlook.CreateItem(olMailItem)

        With objMail

            '设置收件人地址（从通讯录表的'E-mail地址'字段中获得）

            .To = Cells(rowCount, 1)
            
            '设置邮件抄送人
                        
            .CC = Cells(rowCount, 5)

            '设置邮件主题

            .Subject = Cells(rowCount, 2)

            '设置邮件内容（从通讯录表的'内容'字段中获得）

            .Body = Cells(rowCount, 3)

            '设置附件（从通讯录表的'附件'字段中获得）

            .Attachments.Add Cells(rowCount, 4).Value

            '自动发送邮件

            .Save

        End With

        '销毁objMail对象

        Set objMail = Nothing

    Next


    '销毁objOutlook对象
    Set objOutlook = Nothing
    '所有电子邮件发送完成时提示
    MsgBox rowCount - 2 & "个朋友的问候信发送成功！"
    '
    If Application.Workbooks.Count = 1 Then
        Application.Quit
    Else
        Workbooks("自动发送邮件.xls").Close
    End If
    '
End Sub