<think>我们使用VBA和EASendMail组件来实现批量邮件发送。主要步骤包括：1.设置SMTP服务器参数2.从Excel工作表中读取收件人列表（包含员工代号、姓名、单位、邮箱）3.从Outlook草稿箱中获取第一封邮件作为模板（包括HTML正文和附件）4.对每个收件人替换邮件模板中的个性化字段（员工代号、姓名、单位）5.将邮件添加到发送队列，每1000封提交一批6.在Excel中新建工作表记录发送状态（包括员工代号、姓名、单位、邮箱和发送状态）注意：需要先安装EASendMail组件（从官方网站下载并注册），然后在VBA编辑器中引用“EASendMailObj”库。下面是完整的VBA代码实现：```vba'需要引用:EASendMailObjLibrary和MicrosoftOutlookObjectLibrary'工具->引用->勾选"EASendMailObj"和"MicrosoftOutlookXX.XObjectLibrary"OptionExplicitSubSendBulkEmails()DimoSmtpAsNewEASendMailObjLib.MailDimoQueueAsNewEASendMailObjLib.MailQueueDimserverAsNewEASendMailObjLib.SmtpDimwsRecipientsAsWorksheet,wsStatusAsWorksheetDimrecipientsAsVariantDimoutlookAppAsObject,outlookMailAsObjectDimemailTemplateAsStringDimattachmentsAsCollectionDimbatchSizeAsLong:batchSize=1000DimiAsLong,lastRowAsLong,statusRowAsLongDimsendResultAsLongDimtempPathAsStringDimattachmentPathAsString'设置SMTP服务器server.Server="smtp.cht.com.tw"'替换为实际的SMTP服务器server.Username="welfare@cht.com.tw"server.Password="your_password"'替换为实际密码server.Port=587'通常587或465server.ConnectType=EASendMailObjLib.ConnectTypeConnectSSLAuto'自动SSL/TLS'初始化收件人列表SetwsRecipients=ThisWorkbook.Sheets("收件人名单")'工作表名称，根据实际情况修改lastRow=wsRecipients.Cells(wsRecipients.Rows.Count,"A").End(xlUp).Row'假设A列:员工代号,B列:姓名,C列:单位,D列:邮箱recipients=wsRecipients.Range("A2:D"&lastRow).Value'创建状态记录表SetwsStatus=SetupStatusSheet("发送状态")statusRow=2'状态记录起始行'获取Outlook草稿箱的第一封邮件SetoutlookApp=CreateObject("Outlook.Application")SetoutlookMail=GetFirstDraft(outlookApp)IfoutlookMailIsNothingThenMsgBox"草稿箱中未找到邮件！",vbExclamationExitSubEndIf'保存模板的HTML正文和附件emailTemplate=outlookMail.HTMLBodySetattachments=NewCollectionProcessAttachmentsoutlookMail,attachments'初始化邮件队列oQueue.ClearQueueoQueue.Server=server'逐个处理收件人Fori=1ToUBound(recipients,1)DimempIdAsString,fullNameAsString,departmentAsString,emailAsStringempId=recipients(i,1)fullName=recipients(i,2)department=recipients(i,3)email=recipients(i,4)'创建新邮件对象DimpersonalizedMailAsNewEASendMailObjLib.MailpersonalizedMail.FromAddr="welfare@cht.com.tw"personalizedMail.AddRecipientemail,""personalizedMail.Subject=outlookMail.Subject'替换邮件模板中的个性化字段personalizedMail.HTMLBody=ReplaceTemplate(emailTemplate,empId,fullName,department)'添加附件(将原邮件的附件重新附加)DimjAsIntegerForj=1Toattachments.CountpersonalizedMail.AddAttachmentattachments(j)Nextj'添加到队列sendResult=oQueue.Add(personalizedMail)'记录状态wsStatus.Cells(statusRow,1).Value=empIdwsStatus.Cells(statusRow,2).Value=fullNamewsStatus.Cells(statusRow,3).Value=departmentwsStatus.Cells(statusRow,4).Value=emailwsStatus.Cells(statusRow,5).Value=IIf(sendResult=0,"已加入队列","失败("&sendResult&")")statusRow=statusRow+1'每批处理batchSize封邮件后提交一次队列IfiModbatchSize=0ThensendResult=oQueue.SendIfsendResult<>0ThenMsgBox"发送过程中出错，错误代码:"&sendResult,vbExclamationEndIfoQueue.ClearQueue'清除已发送的邮件，准备下一批EndIfNexti'发送最后一批（如果还有剩余）IfUBound(recipients,1)ModbatchSize<>0ThensendResult=oQueue.SendIfsendResult<>0ThenMsgBox"发送最后一批时出错，错误代码:"&sendResult,vbExclamationEndIfEndIf'清理Setattachments=NothingSetoutlookMail=NothingSetoutlookApp=NothingSetoQueue=NothingSetoSmtp=NothingMsgBox"邮件发送完成！共发送了"&UBound(recipients,1)&"封邮件。",vbInformationEndSub'创建状态记录表FunctionSetupStatusSheet(sheetNameAsString)AsWorksheetOnErrorResumeNextApplication.DisplayAlerts=FalseThisWorkbook.Sheets(sheetName).DeleteApplication.DisplayAlerts=TrueDimwsAsWorksheetSetws=ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))ws.Name=sheetNamews.Range("A1:E1").Value=Array("员工代号","姓名","单位","邮箱","发送状态")SetSetupStatusSheet=wsEndFunction'获取草稿箱的第一封邮件FunctionGetFirstDraft(outlookAppAsObject)AsObjectDimdraftsFolderAsObjectSetdraftsFolder=outlookApp.GetNamespace("MAPI").GetDefaultFolder(16)'16是草稿箱IfdraftsFolder.Items.Count>0ThenSetGetFirstDraft=draftsFolder.Items(1)ElseSetGetFirstDraft=NothingEndIfEndFunction'处理邮件附件并保存到临时文件夹SubProcessAttachments(outlookMailAsObject,ByRefcolAsCollection)DimattachmentAsObjectForEachattachmentInoutlookMail.AttachmentstempPath=Environ("TEMP")&"\"&attachment.FileNameattachment.SaveAsFiletempPathcol.AddtempPathNextattachmentEndSub'替换邮件模板中的占位符FunctionReplaceTemplate(templateAsString,empIdAsString,fullNameAsString,departmentAsString)AsStringReplaceTemplate=templateReplaceTemplate=Replace(ReplaceTemplate,"{{员工代号}}",empId)ReplaceTemplate=Replace(ReplaceTemplate,"{{姓名}}",fullName)ReplaceTemplate=Replace(ReplaceTemplate,"{{单位}}",department)'可以添加更多替换规则...EndFunction```###说明1.**SMTP设置**：请将`your_password`替换为实际密码，并根据服务器配置调整端口和连接类型。2.**占位符**：模板中应包含`{{员工代号}}`、`{{姓名}}`和`{{单位}}`作为占位符，代码会将其替换为实际值。3.**附件处理**：将草稿箱邮件的附件保存到临时文件夹，并在发送邮件时重新附加。临时文件不会自动删除，若需要可添加代码在发送后删除。4.**分批发送**：每1000封邮件提交一次队列发送，避免内存不足或超时问题。5.**状态记录**：创建“发送状态”工作表记录每封邮件的发送结果。###安全提示-密码存储：避免在代码中硬编码密码，可考虑使用加密存储或从安全位置读取。-错误处理：当前代码仅做了基本错误处理，实际使用中可增加更详细的错误捕获和重试机制。如果还有其他问题，请随时提出！§§§相关问题§§§1.如何安全地存储SMTP密码避免硬编码？2.批量发送邮件时如何避免被识别为垃圾邮件？3.如何跟踪邮件是否被成功送达而不仅仅是发送到服务器？</think>
# VBA邮件批量发送解决方案
下面是一个完整的VBA解决方案，使用EASendMail和Outlook实现批量邮件发送功能：
```vba
' 需要引用: EASendMailObj Library 和 Microsoft Outlook Object Library
Option Explicit
Sub SendBulkEmails()
Dim oSmtp As New EASendMailObjLib.Mail
Dim oQueue As New EASendMailObjLib.MailQueue
Dim server As New EASendMailObjLib.Smtp
Dim wsRecipients As Worksheet, wsStatus As Worksheet
Dim recipients As Variant
Dim outlookApp As Object, outlookMail As Object
Dim emailTemplate As String
Dim attachments As Collection
Dim batchSize As Long: batchSize = 1000
Dim i As Long, lastRow As Long, statusRow As Long
Dim sendResult As Long
Dim tempPath As String
Dim attachmentPath As String
' 设置SMTP服务器
server.Server = "smtp.cht.com.tw" ' 替换为实际的SMTP服务器
server.Username = "welfare@cht.com.tw"
server.Password = "your_password" ' 替换为实际密码
server.Port = 587 ' 通常587或465
server.ConnectType = EASendMailObjLib.ConnectTypeConnectSSLAuto ' 自动SSL/TLS
' 初始化收件人列表
Set wsRecipients = ThisWorkbook.Sheets("收件人名单") ' 工作表名称，根据实际情况修改
lastRow = wsRecipients.Cells(wsRecipients.Rows.Count, "A").End(xlUp).Row
' 假设A列:员工代号, B列:姓名, C列:单位, D列:邮箱
recipients = wsRecipients.Range("A2:D" & lastRow).Value
' 创建状态记录表
Set wsStatus = SetupStatusSheet("发送状态")
statusRow = 2 ' 状态记录起始行
' 获取Outlook草稿箱的第一封邮件
Set outlookApp = CreateObject("Outlook.Application")
Set outlookMail = GetFirstDraft(outlookApp)
If outlookMail Is Nothing Then
MsgBox "草稿箱中未找到邮件！", vbExclamation
Exit Sub
End If
' 保存模板的HTML正文和附件
emailTemplate = outlookMail.HTMLBody
Set attachments = New Collection
ProcessAttachments outlookMail, attachments
' 初始化邮件队列
oQueue.ClearQueue
oQueue.Server = server
' 逐个处理收件人
For i = 1 To UBound(recipients, 1)
Dim empId As String, fullName As String, department As String, email As String
empId = recipients(i, 1)
fullName = recipients(i, 2)
department = recipients(i, 3)
email = recipients(i, 4)
' 创建新邮件对象
Dim personalizedMail As New EASendMailObjLib.Mail
personalizedMail.FromAddr = "welfare@cht.com.tw"
personalizedMail.AddRecipient email, ""
personalizedMail.Subject = outlookMail.Subject
' 替换邮件模板中的个性化字段
personalizedMail.HTMLBody = ReplaceTemplate(emailTemplate, empId, fullName, department)
' 添加附件 (将原邮件的附件重新附加)
Dim j As Integer
For j = 1 To attachments.Count
personalizedMail.AddAttachment attachments(j)
Next j
' 添加到队列
sendResult = oQueue.Add(personalizedMail)
' 记录状态
wsStatus.Cells(statusRow, 1).Value = empId
wsStatus.Cells(statusRow, 2).Value = fullName
wsStatus.Cells(statusRow, 3).Value = department
wsStatus.Cells(statusRow, 4).Value = email
wsStatus.Cells(statusRow, 5).Value = IIf(sendResult = 0, "已加入队列", "失败(" & sendResult & ")")
statusRow = statusRow + 1
' 每批处理batchSize封邮件后提交一次队列
If i Mod batchSize = 0 Then
sendResult = oQueue.Send
If sendResult <> 0 Then
MsgBox "发送过程中出错，错误代码: " & sendResult, vbExclamation
End If
oQueue.ClearQueue ' 清除已发送的邮件，准备下一批
End If
Next i
' 发送最后一批（如果还有剩余）
If UBound(recipients, 1) Mod batchSize <> 0 Then
sendResult = oQueue.Send
If sendResult <> 0 Then
MsgBox "发送最后一批时出错，错误代码: " & sendResult, vbExclamation
End If
End If
' 清理
Set attachments = Nothing
Set outlookMail = Nothing
Set outlookApp = Nothing
Set oQueue = Nothing
Set oSmtp = Nothing
MsgBox "邮件发送完成！共发送了 " & UBound(recipients, 1) & " 封邮件。", vbInformation
End Sub
' 创建状态记录表
Function SetupStatusSheet(sheetName As String) As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Sheets(sheetName).Delete
Application.DisplayAlerts = True
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = sheetName
ws.Range("A1:E1").Value = Array("员工代号", "姓名", "单位", "邮箱", "发送状态")
Set SetupStatusSheet = ws
End Function
' 获取草稿箱的第一封邮件
Function GetFirstDraft(outlookApp As Object) As Object
Dim draftsFolder As Object
Set draftsFolder = outlookApp.GetNamespace("MAPI").GetDefaultFolder(16) ' 16是草稿箱
If draftsFolder.Items.Count > 0 Then
Set GetFirstDraft = draftsFolder.Items(1)
Else
Set GetFirstDraft = Nothing
End If
End Function
' 处理邮件附件并保存到临时文件夹
Sub ProcessAttachments(outlookMail As Object, ByRef col As Collection)
Dim attachment As Object
For Each attachment In outlookMail.Attachments
tempPath = Environ("TEMP") & "\" & attachment.FileName
attachment.SaveAsFile tempPath
col.Add tempPath
Next attachment
End Sub
' 替换邮件模板中的占位符
Function ReplaceTemplate(template As String, empId As String, fullName As String, department As String) As String
ReplaceTemplate = template
ReplaceTemplate = Replace(ReplaceTemplate, "{{员工代号}}", empId)
ReplaceTemplate = Replace(ReplaceTemplate, "{{姓名}}", fullName)
ReplaceTemplate = Replace(ReplaceTemplate, "{{单位}}", department)
' 可以添加更多替换规则...
End Function
```
## 代码说明
### 主要功能实现
1. **SMTP配置**：
```vba
server.Server = "smtp.cht.com.tw"
server.Username = "welfare@cht.com.tw"
server.Password = "your_password"
```
2. **数据处理流程**：
- 从Excel读取收件人数据
- 从Outlook草稿箱获取邮件模板
- 处理附件和图片
- 批量发送邮件（每1000封提交一次）
- 记录发送状态
3. **邮件个性化**：
在HTML模板中使用占位符如`{{员工代号}}`，程序会自动替换为实际值
### 使用前准备
1. **引用设置**：
- EASendMailObj Library（需先安装EASendMail）
- Microsoft Outlook Object Library
2. **数据格式**：
| 员工代号 | 姓名 | 单位 | 邮箱 |
|----------|------|------|------|
| E001 | 张三 | 研发部 | zhangsan@example.com |
| E002 | 李四 | 市场部 | lisi@example.com |
3. **邮件模板**：
- 在Outlook草稿箱创建HTML格式的邮件
- 使用占位符：`{{员工代号}}`、`{{姓名}}`、`{{单位}}`
- 包含所需附件和内嵌图片
## 常见问题解决
### 1. 安全存储SMTP密码
避免在代码中硬编码密码：
```vba
' 使用Windows API加密函数
Private Declare Function CryptProtectData Lib "crypt32.dll" (..)
Function EncryptPassword(ByVal str As String) As String
' 加密实现...
End Function
Function DecryptPassword(ByVal str As String) As String
' 解密实现...
End Function
' 使用方式
server.Password = DecryptPassword(wsSettings.Range("B1").Value)
```
### 2. 特殊字符处理
处理Excel中的特殊字符：
```vba
Function SanitizeInput(input As String) As String
' 替换可能引起问题的字符
input = Replace(input, "&", "&")
input = Replace(input, "<", "<")
input = Replace(input, ">", ">")
input = Replace(input, """", """)
SanitizeInput = input
End Function
' 使用
fullName = SanitizeInput(recipients(i, 2))
```
### 3. 发送速度优化
```mermaid
graph LR
A[开始] --> B[准备邮件队列]
B --> C{队列满1000?}
C -->|是| D[提交发送]
C -->|否| E[继续添加]
D --> F{全部完成?}
F -->|否| C
F -->|是| G[结束]
```
### 4. 避免视为垃圾邮件
- 添加SPF/DKIM记录
- 控制发送频率（添加随机延迟）
- 包含退订链接
- 使用真实的"发件人"地址
## 扩展功能建议
1. **邮件跟踪**：
```vba
' 添加邮件跟踪头
personalizedMail.AddCustomHeader "Return-Receipt-To", "tracking@yourdomain.com"
```
2. **错误处理增强**：
```vba
On Error Resume Next
' 邮件操作代码...
If Err.Number <> 0 Then
wsStatus.Cells(statusRow, 5) = "错误:" & Err.Description
Err.Clear
End If
On Error GoTo 0
```
3. **图片处理**：
```vba
' 添加嵌入式图片
personalizedMail.AddAttachment "logo.png", , EASendMailObjLib.AttachmentEncodingBase64, "cid:company_logo"
```
## 执行步骤
1. 安装EASendMail组件
2. 在VBA中添加所需引用
3. 准备Outlook邮件模板
4. 准备Excel收件人名单
5. 执行宏`SendBulkEmails`
扫一扫
6688
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
