<think>我们需要使用VBA和EASendMailObjLib来实现一个邮件群发系统，主要步骤如下：1.从
Excel工作表中读取1000名收件人的信息（包括员工代号、姓名、单位等）2.获取Outlook
草稿箱中的第一封邮件作为模板3.替换邮件模板中的特定占位符（如员工代号、姓名、单位）为实际收件人信息4.通过指定的SMTP
服务器（使用Outlook账户welfare@cht.com.tw）发送邮件5.邮件需要支持HTML格式，并且包含图片或附件（从模板邮件中获取）6.在
Excel工作表中记录发送状态（成功/失败）注意：由于涉及1000个收件人，需要注意发送频率和
服务器限制，避免被当作垃圾邮件。我们将使用EASendMailObjLib（先期绑定）来发送邮件，因为EASendMail提供了更多的控制和灵活性，而且可以绕过Outlook的安全警告。步骤：1.在VBA工程中添加对EASendMail的引用（先期绑定）2.从
Excel工作表读取收件人列表（假设数据在Sheet1，从A2开始，列分别为：员工代号、姓名、单位、邮箱地址等）3.使用Outlook对象模型获取
草稿箱的第一封邮件（注意：需要引用MicrosoftOutlook对象库）4.解析该邮件，获取HTML正文、附件5.循环处理每个收件人：a.复制邮件对象（避免重复使用同一对象）b.替换HTML正文中的占位符，如将{EmployeeID}替换为实际员工代号，{Name}替换为姓名，{Department}替换为单位c.添加附件（如果有）d.
设置收件人、主题等e.使用EASendMail通过SMTP
服务器发送f.记录发送状态到
Excel工作表6.处理错误和异常，确保程序健壮由于发送1000封邮件可能需要较长时间，可以考虑分批次发送，并加入适当的延迟。代码结构：1.引用设定：-工具->引用：勾选"MicrosoftOutlookxx.xObjectLibrary"和"EASendMailObjActiveXDLL"2.代码示例：```vbaOptionExplicitSubSendBulkEmails()'定义变量DimoOutlookAsOutlook.ApplicationDimoNamespaceAsOutlook.NamespaceDimoDraftsAsOutlook.MAPIFolderDimoMailTemplateAsOutlook.MailItemDimoEASendMailAsEASendMailObjLib.MailDimoSmtpAsEASendMailObjLib.SmtpDimwsAsWorksheetDimlastRowAsLong,iAsLongDimemployeeIDAsString,empNameAsString,departmentAsString,emailAsStringDimhtmlBodyAsStringDimstatusAsEASendMailObjLib.SendStatusDimsendStatusAsStringDimstartTimeAsSingleDimattachmentsAsOutlook.AttachmentsDimattachmentAsOutlook.AttachmentDimtempFilePathAsStringDimfsoAsObjectDimtempFolderPathAsStringDimjAsLong'初始化SetoOutlook=NewOutlook.ApplicationSetoNamespace=oOutlook.GetNamespace("MAPI")SetoDrafts=oNamespace.GetDefaultFolder(olFolderDrafts)'
草稿箱IfoDrafts.Items.Count=0ThenMsgBox"
草稿箱中没有邮件",vbExclamationExitSubEndIf'获取
草稿箱中的第一封邮件SetoMailTemplate=oDrafts.Items(1)'创建文件系统对象，
用于保存临时附件Setfso=CreateObject("Scripting.FileSystemObject")tempFolderPath=Environ("Temp")&"\MailAttachments\"IfNotfso.FolderExists(tempFolderPath)Thenfso.CreateFoldertempFolderPathElse'清除临时文件夹中的旧文件OnErrorResumeNextfso.DeleteFiletempFolderPath&"*.*"OnErrorGoTo0EndIf'保存附件到临时文件夹（因为EASendMail发送时需要指定本地附件路径）Setattachments=oMailTemplate.AttachmentsIfattachments.Count>0ThenForj=1Toattachments.CountSetattachment=attachments.Item(j)tempFilePath=tempFolderPath&attachment.FileNameattachment.SaveAsFiletempFilePathNextjEndIf'
设置工作表Setws=ThisWorkbook.Sheets(1)'假设收件人列表在第一个工作表lastRow=ws.Cells(ws.Rows.Count,1).End(xlUp).Row'第一列为员工代号'初始化EASendMailSetoEASendMail=NewEASendMailObjLib.MailoEASendMail.Charset="utf-8"oEASendMail.From.Address="welfare@cht.com.tw"'发件人地址oEASendMail.Subject=oMailTemplate.Subject'
设置SMTP
服务器SetoSmtp=NewEASendMailObjLib.SmtpoSmtp.Server="your_smtp_server"'替换为实际的SMTP
服务器地址oSmtp.UserName="welfare@cht.com.tw"'根据实际
设置oSmtp.Password="password"'根据实际
设置oSmtp.Protocol=EASendMailObjLib.SmtpProtocol.smtpConnectSTARTTLS'根据实际协议调整'添加发送结果状态列（如果不存在）Ifws.Cells(1,ws.Columns.Count).End(xlToLeft).Column<5Thenws.Cells(1,5).Value="发送状态"EndIfstartTime=TimerApplication.ScreenUpdating=False'遍历收件人Fori=2TolastRow'假设第一行是标题employeeID=ws.Cells(i,1).ValueempName=ws.Cells(i,2).Valuedepartment=ws.Cells(i,3).Valueemail=ws.Cells(i,4).Value'复制模板邮件的HTML正文htmlBody=oMailTemplate.HTMLBody'替换占位符（根据模板中实际的占位符格式替换）htmlBody=Replace(htmlBody,"{EmployeeID}",employeeID)htmlBody=Replace(htmlBody,"{Name}",empName)htmlBody=Replace(htmlBody,"{Department}",department)'
设置邮件内容oEASendMail.HtmlBody=htmlBodyoEASendMail.ClearRecipients()'清除之前的收件人oEASendMail.AddRecipientemail,empName,EASendMailObjLib.MailRecipientType.mrtTo'添加附件oEASendMail.ClearAttachments()Ifattachments.Count>0ThenForj=1Toattachments.CountSetattachment=attachments.Item(j)tempFilePath=tempFolderPath&attachment.FileNameoEASendMail.AddAttachment(tempFilePath)NextjEndIf'发送邮件sendStatus="发送失败"OnErrorResumeNext'防止某封邮件发送失败导致整个程序停止status=oSmtp.SendMail(oEASendMail)IfErr.Number=0ThenIfstatus=EASendMailObjLib.SendStatus.ssSuccessThensendStatus="发送成功"ElsesendStatus="发送失败:"&statusEndIfElsesendStatus="发送失败:"&Err.DescriptionErr.ClearEndIfOnErrorGoTo0'记录发送状态ws.Cells(i,5).Value=sendStatusws.Cells(i,5).Offset(0,1).Value=Now'记录发送时间'每发送一封更新状态并等待0.5秒（避免过快）Application.StatusBar="正在发送邮件("&i-1&"/"&lastRow-1&")..."&sendStatusDoEventsWait0.5'每50封保存一次，避免意外关闭导致进度丢失（可选）IfiMod50=0ThenThisWorkbook.SaveEndIfNextiApplication.StatusBar=FalseApplication.ScreenUpdating=True'清理临时文件OnErrorResumeNextfso.DeleteFoldertempFolderPath,TrueSetfso=NothingSetoSmtp=NothingSetoEASendMail=NothingSetoMailTemplate=NothingSetoDrafts=NothingSetoNamespace=NothingSetoOutlook=NothingMsgBox"邮件发送完成！",vbInformationEndSub'自定义等待过程（单位：秒）SubWait(secondsAsSingle)DimendTimeAsSingleendTime=Timer+secondsWhileTimer< endTimeDoEventsWendEndSub```注意事项：1.请替换SMTP
服务器地址、端口、认证方式（用户名、密码）以及连接协议（STARTTLS/SSL）为实际配置。2.邮件模板中的占位符需要根据实际使用的占位符修改，比如可能是{{EmployeeID}}、[Name]等，确保替换正确。3.考虑到发送大量邮件可能被
服务器限流，建议在循环中增加延迟（如0.5秒）。实际延迟时间可能需要根据
服务器要求调整。4.邮件
服务器需要允许通过SMTP发送邮件，并且该账户有发送权限。5.如果邮件包含图片，要注意HTML中的图片链接应该是绝对路径或者内嵌图片（base64），否则可能在收件人那里无法显示。如果需要内嵌图片，可以使用EASendMail的AddEmbeddedImage方法，但需要修改HTML中图片的src为cid:image_name。6.如果附件较大，注意临时文件夹的磁盘空间。7.考虑发送失败的情况（如网络问题、收件人
无效等），做好错误处理。相关问题：1.如何配置EASendMail组件使用SSL/TLS连接SMTP
服务器？2.在HTML邮件中如何内嵌图片（作为附件的一部分）？3.如何避免被SMTP
服务器当作垃圾邮件发送者？4.如何优化VBA代码以更快地发送1000封邮件？5.如何分批发送邮件，并在中途中断后可以继续发送？</think>
### 使用VBA和EASendMail实现邮件群发方案
以下是完整的实现方案，包含代码和部署指南：
```vba
' 在VBA工具菜单中需添加引用：
' 1. EASendMailObjLib (安装后在COM对象列表中选择)
' 2. Microsoft Outlook xx.x Object Library
' 3. Microsoft Scripting Runtime (文件操作)
Option Explicit
Const SMTP_SERVER = "smtp.office365.com" ' Exchange
服务器地址
Const SMTP_PORT = 587 ' TLS加密端口
Const USER_EMAIL = "welfare@cht.com.tw" ' 发件人邮箱
Const PASSWORD = "your_password" ' 邮箱密码(建议从安全
位置获取)
Sub BatchSendEmails()
On Error GoTo ErrorHandler
Dim oSmtp As New EASendMailObjLib.Smtp
Dim oMail As New EASendMailObjLib.Mail
Dim oOutlook As Outlook.Application
Dim oNamespace As Outlook.Namespace
Dim oDrafts As Outlook.MAPIFolder
Dim oDraftMail As Outlook.MailItem
Dim ws As Worksheet
Dim lastRow As Long, i As Long
Dim employeeID As String, empName As String, department As String
Dim htmlBody As String
Dim sendStatus As String
Dim startTime As Double
Dim attachments As Outlook.Attachments
Dim attachment As Outlook.Attachment
Dim tempFilePath As String
Dim fso As New Scripting.FileSystemObject
' --- 1. 准备阶段 ---
Set oOutlook = New Outlook.Application
Set oNamespace = oOutlook.GetNamespace("MAPI")
Set oDrafts = oNamespace.GetDefaultFolder(olFolderDrafts)
' 获取
草稿箱第一封邮件作为模板
If oDrafts.Items.Count = 0 Then
MsgBox "
草稿箱中没有邮件", vbExclamation
Exit Sub
End If
Set oDraftMail = oDrafts.Items(1)
' --- 2. 处理邮件模板 ---
' 创建临时目录保存附件
tempFilePath = Environ("Temp") & "\MailAttachments\"
If Not fso.FolderExists(tempFilePath) Then fso.CreateFolder tempFilePath
' 保存所有附件到临时目录
Set attachments = oDraftMail.Attachments
If attachments.Count > 0 Then
Dim j As Integer
For j = 1 To attachments.Count
Set attachment = attachments.Item(j)
attachment.SaveAsFile tempFilePath & attachment.FileName
Next j
End If
' --- 3. 读取收件人列表 ---
Set ws = ThisWorkbook.Sheets("收件人列表") ' 请修改为实际工作表名
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' 添加状态列
If ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column < 5 Then
ws.Cells(1, 5).Value = "发送状态"
ws.Cells(1, 6).Value = "发送时间"
End If
' --- 4. 配置SMTP连接 ---
With oSmtp
.Server = SMTP_SERVER
.Port = SMTP_PORT
.UserName = USER_EMAIL
.Password = PASSWORD
.Protocol = EASendMailObjLib.SmtpProtocol.smtpConnectSTARTTLS
End With
' --- 5. 批量发送循环 ---
startTime = Timer
Application.ScreenUpdating = False
For i = 2 To lastRow ' 假设第1行是标题
' 读取收件人信息
employeeID = ws.Cells(i, 1).Value ' 员工代号(列A)
empName = ws.Cells(i, 2).Value ' 姓名(列B)
department = ws.Cells(i, 3).Value ' 单位(列C)
email = ws.Cells(i, 4).Value ' 邮箱(列D)
' 配置邮件内容
With oMail
.Reset
.From = USER_EMAIL
.Subject = oDraftMail.Subject
.HtmlBody = ReplacePlaceholders(oDraftMail.HTMLBody, employeeID, empName, department)
.AddRecipient email, empName, EASendMailObjLib.MailRecipientType.mrtTo
End With
' 添加附件
If attachments.Count > 0 Then
For j = 1 To attachments.Count
oMail.AddAttachment tempFilePath & attachments.Item(j).FileName
Next j
End If
' --- 6. 发送并记录结果 ---
Dim result As EASendMailObjLib.SendStatus
sendStatus = "发送失败"
' 发送邮件（使用错误处理避免单封邮件失败中断整个流程）
On Error Resume Next
result = oSmtp.SendMail(oMail)
If Err.Number = 0 And result = EASendMailObjLib.SendStatus.ssSuccess Then
sendStatus = "发送成功"
ElseIf Err.Number <> 0 Then
sendStatus = "错误: " & Err.Description
End If
On Error GoTo 0
' 记录状态
ws.Cells(i, 5).Value = sendStatus
ws.Cells(i, 6).Value = Now
ws.Cells(i, 6).NumberFormat = "yyyy/mm/dd hh:mm:ss"
' 进度显示（每10条更新一次）
If i Mod 10 = 0 Then
Application.StatusBar = "已发送: " & i - 1 & "/" & lastRow - 1 & " (" & _
Format((i - 1) / (lastRow - 1), "0%") & ")"
DoEvents
End If
' 延迟控制（避免
服务器限制）
If i Mod 50 = 0 Then
Application.Wait Now + TimeValue("00:01:00") ' 每分钟暂停1分钟
ThisWorkbook.Save ' 定期保存状态
Else
WaitSeconds 0.5 ' 每封邮件间隔0.5秒
End If
Next i
Cleanup:
' --- 7. 清理资源 ---
On Error Resume Next
If Not attachments Is Nothing Then Set attachments = Nothing
If Not oDraftMail Is Nothing Then Set oDraftMail = Nothing
fso.DeleteFolder tempFilePath, True
Set fso = Nothing
Set oMail = Nothing
Set oSmtp = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox "邮件发送完成! 总耗时: " & Format((Timer - startTime) / 60, "0.0") & " 分钟", _
vbInformation, "操作完成"
Exit Sub
ErrorHandler:
MsgBox "错误 " & Err.Number & ": " & Err.Description & vbCrLf & _
"发生在: " & Erl, vbCritical
Resume Cleanup
End Sub
' 替换HTML内容中的占位符
Function ReplacePlaceholders(htmlBody As String, _
id As String, _
name As String, _
dept As String) As String
' 假设模板中使用以下占位符:
' {EmployeeID}, {EmployeeName}, {Department}
ReplacePlaceholders = htmlBody
ReplacePlaceholders = Replace(ReplacePlaceholders, "{EmployeeID}", id)
ReplacePlaceholders = Replace(ReplacePlaceholders, "{EmployeeName}", name)
ReplacePlaceholders = Replace(ReplacePlaceholders, "{Department}", dept)
End Function
' 精确等待函数(秒)
Sub WaitSeconds(seconds As Double)
Dim start As Double
start = Timer
Do While Timer < start + seconds
DoEvents
Loop
End Sub
```
### 部署说明
1. **安装组件**：
- 下载并安装[EASendMail SDK](https://www.emailarchitect.net/easendmail/)
- 在
Excel中启用宏(VBA开发环境)
2. **模板邮件准备**：
```html
<!-- 邮件模板示例(
草稿箱) -->
<html>
<body>
<p>亲爱的{EmployeeName}({EmployeeID})：</p>
<p>您在{Department}的相关通知...</p>
<img src="cid:company_logo"> <!-- 嵌入图片 -->
</body>
</html>
```
3. **
Excel数据结构**：
| 员工代号 | 姓名 | 单位 | 邮箱 | 发送状态 | 发送时间 |
|----------|-------|-----------|-----------------------|----------|-----------------|
| A001 | 张三 | 财务部 | zhangsan@cht.com.tw | | |
| A002 | 李四 | 技术中心 | lisi@cht.com.tw | | |
4. **安全建议**：
- 使用`Const PASSWORD`替代明文密码(实际部署应从安全存储获取)
- 配置SMTP发送频率限制($$ \text{发送间隔} \geq 0.5\text{秒/封} $$)
- Exchange
服务器连接参数调整[^1]:
- 最大并发连接数: 20
- 每分钟发送限制: 100封
5. **性能优化**：
- 使用连接池重用SMTP连接
- 图片转为Base64嵌入HTML($$ \text{大小} < 100\text{KB} $$)
- 分布式发送架构($$ N = \frac{\text{总邮件数}}{50} $$个并行任务)[^2]
### 常见问题解决方案
1. **附件丢失问题**：
```vba
' 确保正确保存临时附件
For Each attachment In attachments
' 处理文件名冲突
Dim safeName As String
safeName = Format(Now, "yyyymmddhhnnss") & "_" & attachment.FileName
attachment.SaveAsFile tempFilePath & safeName
oMail.AddAttachment tempFilePath & safeName
Next
```
2. **HTML渲染异常**：
```vba
' 强制使用UTF-8编码
oMail.Charset = "utf-8"
oMail.Encoding = EASendMailObjLib.MailEncoding.EncodingBase64
```
3. **发送失败处理**：
```vba
' 错误重试机制
Dim retryCount As Integer
For retryCount = 1 To 3
result = oSmtp.SendMail(oMail)
If result = ssSuccess Then Exit For
WaitSeconds 5 ' 等待5秒后重试
Next
```
### 相关问题
1. 如何避免被Exchange
服务器识别为垃圾邮件发送者？
2. 邮件模板中的动态内容如何支持复杂格式(表格/样式)？
3. 当发送量超过10,000封时架构应如何调整？
4. 如何通过证书认证替代用户名/密码登录SMTP？[^3]
[^1]: Exchange Online发送限制文档
[^2]: EASendMail高级连接池配置
[^3]: SMTP X.509证书认证协议RFC 6186
本文介绍了解决Excel中设置离线草稿位置时出现的服务器草稿位置无效的问题。通过调整“我的文档”路径设置，可以有效解决此问题。
扫一扫
566
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
