Excel批量发送带附件的电子邮件

对于批量发送邮件,大家最常用的是word的邮件合并功能,但是有一个弊端是他没有办法发附件。而很多情形,我们是希望邮件除了正文还能够包含附件。这就需要用到Excel的VBA功能了,

方案一,CSDN方案1(win7,outlook2010测试)

功能:

  • 可设置变量,替换邮件正文内容;
  • 彩色邮件、可换行、表格;(需了解HTML标签)
  • 发送不同的附件。

图表如下:

VBA代码如下:

Public Declare Function SetTimer Lib "user32" _
        (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerfunc As Long) As Long
Public Declare Function KillTimer Lib "user32" _
        (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
 
 
Function WinProcA(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal SysTime As Long) As Long
    KillTimer 0, idEvent
    DoEvents
    Sleep 100
    '使用Alt+S发送邮件,这是本文的关键之处,免安全提示自动发送邮件全靠它了
    Application.SendKeys "%s"
End Function
 
 
' 发送单个邮件的子程序
Sub SendMail(ByVal to_who As String, ByVal subject As String, ByVal body As String, ByVal attachement As String)
    Dim objOL As Object
    Dim itmNewMail As Object
    '引用Microsoft Outlook 对象
    Set objOL = CreateObject("Outlook.Application")
    Set itmNewMail = objOL.CreateItem(olMailItem)
    With itmNewMail
        .subject = subject  '主题
        .HTMLbody = body   '正文本文
        .To = to_who  '收件者
        .Attachments.Add attachement '附件
        .Display  '启动Outlook发送窗口
        SetTimer 0, 0, 0, AddressOf WinProcA
    End With
    Set objOL = Nothing
    Set itmNewMail = Nothing
End Sub
 

'批量发送邮件
Sub BatchSendMail()
    Dim rowCount, endRowNo
    Dim newBody
    Dim replaceCount, maxReplaceCount
    Dim pattern
    
    
    Dim i As Integer, j As Integer
    i = Cells(3, 1).Value
    j = Cells(3, 2).Value
    
    '逐行发送邮件
    For rowCount = (i + 4) To (j + 4)
        ' 替换当前行模板内容
        maxReplaceCount = 8   ' 有几个变量就写几
        newBody = Cells(rowCount, 4)
 
        For replaceCount = 1 To maxReplaceCount
            pattern = "[==" & CStr(replaceCount) & "==]"
            newBody = WorksheetFunction.Substitute(newBody, pattern, Cells(rowCount, 5 + replaceCount))
        Next
        ' 替换好了,发邮件咯!
        SendMail Cells(rowCount, 2), Cells(rowCount, 3), newBody, Cells(rowCount, 5)
        
    Next
    Cells(3, 1).Value = i + 5
    Cells(3, 2).Value = j + 5
    
End Sub

注意:

  • 正文需用HTML标签, HTML代码可以在W3C school测试效果。

常用HTML标签:

  • 段落: <p></p>
  • 加粗: <b></b>
  • 颜色: <font color="red"></font>

提示:仅仅有 16 种颜色名被 W3C 的 HTML4.0 标准所支持。它们是:aqua, black, blue, fuchsia, gray, green, lime, maroon, navy, olive, purple, red, silver, teal, white, yellow。3

变量部分用[==xxxx==]这样的形式替换掉。注意:中间没有空格。 数字[==1==]会被E列的内容替换掉,[==2==]会被F列的内容替换掉,依此类推,如果有更多,就添加更多列,[==3==], [==4==]等等。

  • 附件路径可以有中文,但是不能有空格。每一行将是一个邮件

为了正确执行代码,还需要在菜工具->引用 中的Microseft Outlook X.0 Object Library  勾选上 (X.0是版本号)

表格

方案二:知乎方案 2 ,结合CSDN (win10,outlook2017测试)

对于excel工作表,从A1开始,可描述题头:第一列:收件人;第二列:主题;第三列:正文;第四列:附件路径; 第五列:变量一; 第六列:变量二

从A2开始,对应题头填写实际收件人,主题,正文,附件路径,变量……

代码如下:

Sub sendBatchMail()
 t = Timer   '计时器开始

Dim rowCount, endRowNo
Dim objOutlook As New Outlook.Application
Dim objMail As MailItem
Dim sendIndex
Dim replaceCount, maxReplaceCount
Dim pattern
endRowNo = Cells(1, 1).CurrentRegion.Rows.Count


Set objOutlook = New Outlook.Application

ThisWorkbook.Sheets("sheet1").Select

For rowCount = 2 To endRowNo '循环从第二行运行到最后一行

' 替换当前行模板内容
maxReplaceCount = 2   ' 有几处替换就写几,有2个变量,就写2
newBody = Cells(rowCount, 3)
 
        For replaceCount = 1 To maxReplaceCount
            pattern = "[==" & CStr(replaceCount) & "==]"
            newBody = WorksheetFunction.Substitute(newBody, pattern, Cells(rowCount, 4 + replaceCount)) ' 从4+N列为变量
                    
        Next
        '替换完毕

Set objMail = objOutlook.CreateItem(olMailItem)
subjectname = ThisWorkbook.Sheets("sheet1").Range("b" & rowCount) '赋值邮件名
bodyname = newBody '赋值邮件正文
attach_address = ThisWorkbook.Sheets("sheet1").Range("d" & rowCount) '赋值附件路径
With objMail
.To = Cells(rowCount, 1)
.Attachments.Add attach_address
.HTMLBody = bodyname
.Subject = subjectname
sendIndex = rowCount Mod objOutlook.Session.Accounts.Count + 1
'要发的邮件分到服务器上
.SendUsingAccount = objOutlook.Session.Accounts.Item(sendIndex)
.Send
End With
Set objMail = Nothing

Application.Wait (Now + TimeValue("0:00:5"))
 '发完一封邮件等5秒左右,时间可以自己调整
Next

MsgBox "发送完毕!" & Chr(10) & "用时" & Timer - t & "seconds" & Chr(10) & "A VBA application modified by colinjiang.com"
 '结束后,显示计时器结果
End Sub

参考文献

  1. CSDN. 利用Excel批量快速发送电子邮件 [OL]. https://blog.csdn.net/maray/article/details/8133923
  2. 知乎 闲者秋山 .用Excel和OutLook实现自动批量发邮件[OL].https://zhuanlan.zhihu.com/p/25283201
  3. HTML 颜色[OL].https://www.w3school.com.cn/html/html_colors.asp

发表评论

电子邮件地址不会被公开。 必填项已用*标注