工作需要,每个月都要群发邮件给不同team,邮件主题,cc信息等都根据team划分不同。手工发送经常用掉我大半时间,并且可能会有出错情况,想着还是写个小工具节省一些时间。
首先,需要在VBA 中添加Outlook的组件: Tools > References, 勾选”Microsoft Office 16.0 Object Library。截图如下:
设想是发送不同邮件给不同的人,并且添加的附件也不一样,因此在excel中,建立以下几项:
A1: Receiver Address #收件人邮箱,多个收件人可用 ; 分开
B1: CC Address #抄送人邮箱
C1: Subject #邮件主题
D1:Content #邮件内容(选填),内容少可简单填写,或在VBA中输入
E1:Attachment # 附件的绝对路径
设置好后,就可以开始输入代码,完整代码如下:
Sub monthly_brief()
Dim outlookApp As Outlook.Application
Dim myMail As Outlook.MailItem
Dim sh As Worksheet
Dim cell, Filecell, rng As Range
Dim source_file, to_emails, cc_emails As String
Dim i, j As Integer
Dim xOutMsg As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("sheet1")
Set outlookApp = New Outlook.Application
strbody = " Dear all,
"
strbody = strbody & "正文"<br>
strbody = strbody & " " '这里使用html格式编辑正文,可以根据需要调整字体,大小颜色等
For Each cell In sh.Columns("A").Cells.SpecialCells(xlCellTypeConstants)
Set rng = sh.Cells(cell.Row, 1).Range("E1:M1")
If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set myMail = outlookApp.CreateItem(0)
With myMail
.Display '此处Display是为了添加default Outlook签名
.To = sh.Cells(cell.Row, 1).Value
.CC = sh.Cells(cell.Row, 2).Value
.Subject = sh.Cells(cell.Row, 3).Value
Signature = .HTMLBody
.HTMLBody = strbody & "
" & Signature
'添加附件
For Each Filecell In rng.SpecialCells(xlCellTypeConstants)
If Trim(Filecell.Value) <> "" Then
If Dir(Filecell.Value) <> "" Then
.Attachments.Add Filecell.Value
End If
End If
Next Filecell
'.send 正式发送可以将 ' 去掉
.Display '预览效果
End With
Set myMail = Nothing
End If
Next cell
Set outlookApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
以上是整个流程。