Outlook 群发邮件并添加不同附件 -VBA

工作需要，每个月都要群发邮件给不同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

以上是整个流程。