功能说明- 支持一键全部发送
- 支持自定义单独发送
- 支持多收件人
- 支持多抄送人
- 支持签名（可以自定义修改VB代码）
- 支持多附件（最多五个）
软件环境Microsoft Office 2019
Outlook
Private Const COMMA_EN As String = ","
Private Const SEMICOLON_EN As String = ";"
Private Const AT_EN As String = "@"
Private Const EXCEL_FORMAT As String = ".xlsx"
Sub BatchSendEmail()
Dim lastLine As Integer '查询所有邮件数据总条数
lastLine = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Row '最后一行
If lastLine < 3 Then
Dim notFindError As Integer
notFindError = MsgBox("未发现要发送的邮件列表", vbYes, "提示")
Exit Sub
End If
' 获取邮件列表 Sheet
Set mailSheet = Sheets("批量发送邮件")
' 声明邮件属性列
Dim startLine As Integer, sendTagNum As Integer, toNum As Integer, cCNum As Integer, subjectNum As Integer, bodyNum As Integer
Dim attachmentsPath As String, statisticsEmailNum As Integer, errorCode As Integer
Dim attachment01Num As Integer, attachment02Num As Integer, attachment03Num As Integer, attachment04Num As Integer, attachment05Num As Integer
sendTagNum = 1
toNum = 3 ' 收件人
cCNum = toNum + 1 ' 抄送
subjectNum = toNum + 2 ' 主题
bodyNum = toNum + 3 ' 正文
attachmentsPath = Trim(AttachmentsPath_Label.Caption)
attachment01Num = toNum + 4 ' 附件
attachment02Num = toNum + 5 ' 附件
attachment03Num = toNum + 6 ' 附件
attachment04Num = toNum + 7 ' 附件
attachment05Num = toNum + 8 ' 附件
statisticsEmailNum = 0 ' 统计待发送邮件数量
' 检查数据
For startLine = 3 To lastLine Step 1
' 检查 发送状态
Dim sendTag As String
sendTag = mailSheet.Cells(startLine, sendTagNum).value
If Trim(sendTag) <> "是" Then
GoTo here
End If
statisticsEmailNum = statisticsEmailNum + 1
' 检查 收件人
Dim toEmails As String
toEmails = Trim(mailSheet.Cells(startLine, toNum).value)
If Len(toEmails) = 0 Then
Dim toEmailsPathError As Integer
toEmailsPathError = MsgBox("第 " & startLine & " 行收件人是空", vbYes, "提示")
mailSheet.Cells(startLine, toNum).Select
Exit Sub
End If
' 检查 收件人邮箱格式
Dim toEmailItem() As String
toEmailItem = Split(toEmails, SEMICOLON_EN)
Dim i
For i = 0 To UBound(toEmailItem)
If InStr(toEmailItem(i), AT_EN) = 0 Then
Dim toEmailsFormatError As Integer
toEmailsFormatError = MsgBox("第 " & startLine & " 行收件人邮箱格式不正确", vbYes, "提示")
mailSheet.Cells(startLine, toNum).Select
Exit Sub
End If
Next
' 检查 抄送人邮箱格式
Dim cCEmails As String
cCEmails = mailSheet.Cells(startLine, cCNum).value
If Len(Trim(cCEmails)) <> 0 Then
Dim cCEmailItem() As String
cCEmailItem = Split(cCEmails, SEMICOLON_EN)
Dim cCEmailItemNum
For cCEmailItemNum = 0 To UBound(cCEmailItem)
If InStr(cCEmailItem(cCEmailItemNum), AT_EN) = 0 Then
Dim cCEmailsFormatError As Integer
cCEmailsFormatError = MsgBox("第 " & startLine & " 行抄送人邮箱格式不正确", vbYes, "提示")
mailSheet.Cells(startLine, cCNum).Select
Exit Sub
End If
Next
End If
' 检查 主题
Dim emailSubject As String
emailSubject = mailSheet.Cells(startLine, subjectNum).value
If Len(Trim(emailSubject)) = 0 Then
Dim emailSubjectError As Integer
emailSubjectError = MsgBox("第 " & startLine & " 行主题是空的", vbYes, "提示")
mailSheet.Cells(startLine, subjectNum).Select
Exit Sub
End If
' 检查 正文
Dim emailBody As String
emailBody = mailSheet.Cells(startLine, bodyNum).value
If Len(Trim(emailBody)) = 0 Then
Dim emailBodyError As Integer
emailBodyError = MsgBox("第 " & startLine & " 行邮件内容是空的", vbYes, "提示")
mailSheet.Cells(startLine, bodyNum).Select
Exit Sub
End If
' 检查 附件
If Len(attachmentsPath) <> 0 Then
Dim everyFilePath As String, everyFilePathError As Integer, attachment01Name As String, attachment02Name As String, attachment03Name As String, attachment04Name As String, attachment05Name As String
' 第一个附件
attachment01Name = Trim(mailSheet.Cells(startLine, attachment01Num).value)
If Len(attachment01Name) <> 0 Then
everyFilePath = Dir(attachmentsPath & "\" & mailSheet.Cells(startLine, attachment01Num) & EXCEL_FORMAT)
If everyFilePath = "" Then
everyFilePathError = MsgBox("第 " & startLine & " 行邮件附件没有找到", vbYes, "提示")
mailSheet.Cells(startLine, attachment01Num).Select
Exit Sub
End If
End If
' 第二个附件
attachment02Name = Trim(mailSheet.Cells(startLine, attachment02Num).value)
If Len(attachment02Name) <> 0 Then
everyFilePath = Dir(attachmentsPath & "\" & mailSheet.Cells(startLine, attachment02Num) & EXCEL_FORMAT)
If everyFilePath = "" Then
everyFilePathError = MsgBox("第 " & startLine & " 行邮件附件-2没有找到", vbYes, "提示")
mailSheet.Cells(startLine, attachment02Num).Select
Exit Sub
End If
End If
' 第三个附件
attachment03Name = Trim(mailSheet.Cells(startLine, attachment03Num).value)
If Len(attachment03Name) <> 0 Then
everyFilePath = Dir(attachmentsPath & "\" & mailSheet.Cells(startLine, attachment03Num) & EXCEL_FORMAT)
If everyFilePath = "" Then
everyFilePathError = MsgBox("第 " & startLine & " 行邮件附件-3没有找到", vbYes, "提示")
mailSheet.Cells(startLine, attachment03Num).Select
Exit Sub
End If
End If
' 第四个附件
attachment04Name = Trim(mailSheet.Cells(startLine, attachment04Num).value)
If Len(attachment04Name) <> 0 Then
everyFilePath = Dir(attachmentsPath & "\" & mailSheet.Cells(startLine, attachment04Num) & EXCEL_FORMAT)
If everyFilePath = "" Then
everyFilePathError = MsgBox("第 " & startLine & " 行邮件附件-4没有找到", vbYes, "提示")
mailSheet.Cells(startLine, attachment04Num).Select
Exit Sub
End If
End If
' 第五个附件
attachment05Name = Trim(mailSheet.Cells(startLine, attachment05Num).value)
If Len(attachment05Name) <> 0 Then
everyFilePath = Dir(attachmentsPath & "\" & mailSheet.Cells(startLine, attachment05Num) & EXCEL_FORMAT)
If everyFilePath = "" Then
everyFilePathError = MsgBox("第 " & startLine & " 行邮件附件-5没有找到", vbYes, "提示")
mailSheet.Cells(startLine, attachment05Num).Select
Exit Sub
End If
End If
End If
here:
Next
' 判断是否存在待发送邮件
If statisticsEmailNum = 0 Then
errorCode = MsgBox("没有要发送的邮件数据, 可以修改是否发送状态", vbYes, "提示")
Exit Sub
End If
Dim signHtml As String '定义签名
signHtml = "<div><br></div><div><br></div><div style='position:relative;zoom:1'>" & _
"<div align='left' style='line-height: normal;'><font color='#000000' face='SimSun' size='3'><strong>公司名称 </strong></font></div>" & _
"<div align='left' style='line-height: normal;'><font color='#000000'><span class='short_text' id='result_box' lang='en' ei='4' ec='undefined'><span><font face='SimSun' size='3'><strong>Human Resources / 人力资源部</strong></font></span></span></font><font face='SimSun' size='3'><strong></strong></font></div>" & _
"<div align='left' style='line-height: normal;'><font face='SimSun' size='3'><strong>Tel/电话:＋86(0371)123456</strong></font></div>" & _
"<div align='left' style='line-height: normal;'><font face='SimSun' size='3'><strong>Mp/手机:＋86 17701234567</strong></font></div>" & _
"<div align='left' style='line-height: normal;'><font face='SimSun' size='3'><strong>Email/邮箱：<a href='mailto:p-e.officer@dx-home.com' target='_blank' rel='noopener'>youxiang@163.com</a></strong></font></div>" & _
"<div style='clear:both'></div>" & _
"</div>"
signHtml = " "
' 开始循环发送邮件 第3行开始
Dim sendEmailNum As Integer
sendEmailNum = 0
For startLine = 3 To lastLine Step 1
' 检查 发送状态
Dim runSendTag As String
runSendTag = mailSheet.Cells(startLine, sendTagNum).value
If Trim(runSendTag) <> "是" Then
GoTo runHere
End If
Rows(startLine).Select
sendEmailNum = sendEmailNum + 1
' 声明 Outlook
Dim Mail As Outlook.Application
Set Mail = New Outlook.Application
' 声明 Outlook MailItem
Dim olMailItemLiu As Outlook.MailItem
Set olMailItemLiu = Mail.CreateItem(olMailItem)
' 收件人
olMailItemLiu.To = mailSheet.Cells(startLine, toNum) '收件人
' 抄送
If Len(mailSheet.Cells(startLine, 2)) <> 0 Then
olMailItemLiu.CC = mailSheet.Cells(startLine, cCNum)
End If
' 主题
olMailItemLiu.Subject = mailSheet.Cells(startLine, subjectNum)
' 正文
olMailItemLiu.BodyFormat = olFormatHTML
olMailItemLiu.HTMLBody = mailSheet.Cells(startLine, bodyNum) & signHtml
' 附件
If Len(attachmentsPath) <> 0 Then
If Len(mailSheet.Cells(startLine, 7)) <> 0 Then
olMailItemLiu.Attachments.Add attachmentsPath & "\" & Trim(mailSheet.Cells(startLine, attachment01Num).value) & EXCEL_FORMAT
End If
If Len(mailSheet.Cells(startLine, 8)) <> 0 Then
olMailItemLiu.Attachments.Add attachmentsPath & "\" & Trim(mailSheet.Cells(startLine, attachment02Num)) & EXCEL_FORMAT
End If
If Len(mailSheet.Cells(startLine, 9)) <> 0 Then
olMailItemLiu.Attachments.Add attachmentsPath & "\" & Trim(mailSheet.Cells(startLine, attachment03Num)) & EXCEL_FORMAT
End If
If Len(mailSheet.Cells(startLine, 10)) <> 0 Then
olMailItemLiu.Attachments.Add attachmentsPath & "\" & Trim(mailSheet.Cells(startLine, attachment04Num)) & EXCEL_FORMAT
End If
If Len(mailSheet.Cells(startLine, 11)) <> 0 Then
olMailItemLiu.Attachments.Add attachmentsPath & "\" & Trim(mailSheet.Cells(startLine, attachment05Num)) & EXCEL_FORMAT
End If
End If
olMailItemLiu.Display '启动Outlook发送窗口
olMailItemLiu.Send '执行发送
runHere:
Next
Dim sendEmailSuccess As Integer
sendEmailSuccess = MsgBox("共发送邮件：" & sendEmailNum & " 封", vbYes, "邮件发送完成")
End Sub
' 全部发送 按钮状态
Private Sub AllSendTag_CheckBox_Click()
' MsgBox AllSendTag_CheckBox.value
Dim lastLine As Integer '查询所有邮件数据总条数
lastLine = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Row '最后一行
If lastLine < 3 Then
Dim notFindError As Integer
notFindError = MsgBox("未发现要发送的邮件列表", vbYes, "提示")
Exit Sub
End If
Dim sendTag As String
If AllSendTag_CheckBox.value Then
sendTag = "是"
Else
sendTag = "否"
End If
For startLine = 3 To lastLine Step 1
Range("A" & startLine).value = sendTag
' If sendTag = "是" Then
'Range("A" & startLine).Interior.ColorIndex = 4
'Else
'Range("A" & startLine).Interior.ColorIndex = 3
'End If
Next
End Sub
' 选择附件文件路径
Sub ChooseFilePath()
Dim l As Long
Dim path As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
AttachmentsPath_Label.Caption = .SelectedItems(1)
End If
End With
End Sub下载地址
灵境云