VBA自动化生成Word并Outlook发送，格式未生效问题咨询

我尝试通过VBA实现自动化创建带格式（字号、字体样式、对齐方式）的Word文档，并通过Outlook发送，但文档的格式设置未生效。Excel表格仅有两列，A列存邮箱地址，B列存付款金额，以下是我的代码：

Sub SendEmail()
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim ws As Worksheet
Dim rngEmails As Range
Dim cell As Range
Dim strFolderPath As String
Dim strFilePath As String
Dim fileName As String
Dim name As String

' 指定Word文件的保存路径
strFolderPath = "C:\Users\VBA\WordFiles\"

' 创建Outlook应用对象
Set OutlookApp = CreateObject("Outlook.Application")

' 设置存储邮箱地址和付款金额的工作表
Set ws = ThisWorkbook.Sheets("Feuil1") ' 将"Feuil1"替换为实际工作表名称

' 查找A列最后一行有数据的行号
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

' 遍历范围内的每个单元格
For Each cell In ws.Range("A2:A" & lastRow)
    ' 检查单元格是否非空且包含有效的邮箱地址
    If Not IsEmpty(cell.Value) And IsValidEmail(cell.Value) Then
        ' 从B列获取付款金额
        Dim paymentAmount As Variant
        paymentAmount = ws.Cells(cell.Row, "B").Value
        
        ' 从邮箱地址中提取名称
        name = Split(cell.Value, "@")(0)
        
        ' 生成文件名
        fileName = "Payment_" & name & ".docx"
        
        ' 创建新的Word文档
        Dim wordApp As Object
        Set wordApp = CreateObject("Word.Application")
        wordApp.Visible = False ' 若需查看Word窗口，设置为True
        
        ' 创建新文档
        Dim doc As Object
        Set doc = wordApp.Documents.Add
        
        ' 设置字体大小和样式
        With doc.Content
            .Font.Size = 12
            .Font.Bold = True
            .ParagraphFormat.Alignment = 3 ' 居中对齐
            .InsertAfter "Dear " & name & "," & vbCrLf & vbCrLf
            .Font.Size = 11
            .Font.Bold = False
            .ParagraphFormat.Alignment = 0 ' 左对齐
            .InsertAfter "We are pleased to inform you that your monthly payment for the amount of $" & paymentAmount & " is ready for processing." & vbCrLf & vbCrLf
            .InsertAfter "Please find the details below:" & vbCrLf & vbCrLf
            .Font.Bold = True
            .InsertAfter "Payment Details:" & vbCrLf
            .Font.Bold = False
            .InsertAfter "- Amount: $" & paymentAmount & vbCrLf & vbCrLf
            .InsertAfter "Kind regards," & vbCrLf & "Your Company"
        End With
        
        ' 保存文档
        strFilePath = strFolderPath & fileName
        doc.SaveAs2 strFilePath
        doc.Close
        
        ' 发送附带创建好的Word文档的邮件
        Set OutlookMail = OutlookApp.CreateItem(0) ' 0代表邮件项
        With OutlookMail
            .To = cell.Value ' 将收件人设置为当前单元格中的邮箱地址
            .Subject = "Monthly Payment Details" ' 设置邮件主题
            .Body = "Dear " & name & "," & vbCrLf & vbCrLf & _
                    "Please find your monthly payment details attached." & vbCrLf & vbCrLf & _
                    "Kind regards," & vbCrLf & "Your Company" ' 设置邮件正文
            .Attachments.Add strFilePath ' 附加Word文档
            .Send ' 立即发送邮件
        End With
        Set OutlookMail = Nothing
        
        ' 关闭Word应用程序
        wordApp.Quit
        Set wordApp = Nothing
    End If
Next cell

' 清理对象
Set OutlookApp = Nothing
End Sub

Function IsValidEmail(emailAddress As String) As Boolean
    ' 使用正则表达式检查邮箱地址是否有效
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "^[\w\.-]+@[a-zA-Z\d\.-]+\.[a-zA-Z]{2,}$"
    IsValidEmail = regex.Test(emailAddress)
End Function

问题原因 #

直接操作doc.Content时，后续的格式设置会覆盖整个文档内容的格式，而非仅应用到即将插入的文本。比如先设置12号加粗居中并插入"Dear..."，之后修改字号为11号、取消加粗，这会把整个文档内容的格式都改成11号不加粗，导致之前设置的格式完全失效。

解决方案 #

改用Range对象或逐段落设置格式，确保每一段文本的格式只作用于自身。以下是修改后的完整代码：

Sub SendEmail()
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim ws As Worksheet
Dim cell As Range
Dim strFolderPath As String
Dim strFilePath As String
Dim fileName As String
Dim name As String

' 指定Word文件的保存路径
strFolderPath = "C:\Users\VBA\WordFiles\"

' 创建Outlook应用对象
Set OutlookApp = CreateObject("Outlook.Application")

' 设置存储邮箱地址和付款金额的工作表
Set ws = ThisWorkbook.Sheets("Feuil1") ' 将"Feuil1"替换为实际工作表名称

' 查找A列最后一行有数据的行号
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

' 遍历范围内的每个单元格
For Each cell In ws.Range("A2:A" & lastRow)
    ' 检查单元格是否非空且包含有效的邮箱地址
    If Not IsEmpty(cell.Value) And IsValidEmail(cell.Value) Then
        ' 从B列获取付款金额
        Dim paymentAmount As Variant
        paymentAmount = ws.Cells(cell.Row, "B").Value
        
        ' 从邮箱地址中提取名称
        name = Split(cell.Value, "@")(0)
        
        ' 生成文件名
        fileName = "Payment_" & name & ".docx"
        
        ' 创建新的Word文档
        Dim wordApp As Object
        Set wordApp = CreateObject("Word.Application")
        wordApp.Visible = False ' 若需查看Word窗口，设置为True
        
        ' 创建新文档
        Dim doc As Object
        Set doc = wordApp.Documents.Add
        
        ' 定义Range对象，用于逐段插入并设置格式
        Dim rng As Object
        Set rng = doc.Content
        
        ' 第一段：Dear XXX, （12号、加粗、居中）
        rng.InsertAfter "Dear " & name & "," & vbCrLf & vbCrLf
        Set rng = doc.Paragraphs(doc.Paragraphs.Count).Range
        With rng
            .Font.Size = 12
            .Font.Bold = True
            .ParagraphFormat.Alignment = 3 ' 居中对齐
        End With
        
        ' 第二段：付款通知正文（11号、常规、左对齐）
        rng.Collapse 0 ' 光标移到当前范围末尾
        rng.InsertAfter "We are pleased to inform you that your monthly payment for the amount of $" & paymentAmount & " is ready for processing." & vbCrLf & vbCrLf
        Set rng = doc.Paragraphs(doc.Paragraphs.Count).Range
        With rng
            .Font.Size = 11
            .Font.Bold = False
            .ParagraphFormat.Alignment = 0 ' 左对齐
        End With
        
        ' 第三段：提示查看详情（11号、常规、左对齐）
        rng.Collapse 0
        rng.InsertAfter "Please find the details below:" & vbCrLf & vbCrLf
        Set rng = doc.Paragraphs(doc.Paragraphs.Count).Range
        With rng
            .Font.Size = 11
            .Font.Bold = False
            .ParagraphFormat.Alignment = 0
        End With
        
        ' 第四段：Payment Details（11号、加粗、左对齐）
        rng.Collapse 0
        rng.InsertAfter "Payment Details:" & vbCrLf
        Set rng = doc.Paragraphs(doc.Paragraphs.Count).Range
        With rng
            .Font.Size = 11
            .Font.Bold = True
            .ParagraphFormat.Alignment = 0
        End With
        
        ' 第五段：金额详情（11号、常规、左对齐）
        rng.Collapse 0
        rng.InsertAfter "- Amount: $" & paymentAmount & vbCrLf & vbCrLf
        Set rng = doc.Paragraphs(doc.Paragraphs.Count).Range
        With rng
            .Font.Size = 11
            .Font.Bold = False
            .ParagraphFormat.Alignment = 0
        End With
        
        ' 第六段：问候语（11号、常规、左对齐）
        rng.Collapse 0
        rng.InsertAfter "Kind regards," & vbCrLf & "Your Company"
        Set rng = doc.Paragraphs(doc.Paragraphs.Count - 1).Range ' 选中"Kind regards,"段落
        With rng
            .Font.Size = 11
            .Font.Bold = False
            .ParagraphFormat.Alignment = 0
        End With
        Set rng = doc.Paragraphs(doc.Paragraphs.Count).Range ' 选中公司名称段落
        With rng
            .Font.Size = 11
            .Font.Bold = False
            .ParagraphFormat.Alignment = 0
        End With
        
        ' 保存文档
        strFilePath = strFolderPath & fileName
        doc.SaveAs2 strFilePath
        doc.Close
        
        ' 发送附带创建好的Word文档的邮件
        Set OutlookMail = OutlookApp.CreateItem(0) ' 0代表邮件项
        With OutlookMail
            .To = cell.Value ' 将收件人设置为当前单元格中的邮箱地址
            .Subject = "Monthly Payment Details" ' 设置邮件主题
            .Body = "Dear " & name & "," & vbCrLf & vbCrLf & _
                    "Please find your monthly payment details attached." & vbCrLf & vbCrLf & _
                    "Kind regards," & vbCrLf & "Your Company" ' 设置邮件正文
            .Attachments.Add strFilePath ' 附加Word文档
            .Send ' 立即发送邮件
        End With
        Set OutlookMail = Nothing
        
        ' 关闭Word应用程序
        wordApp.Quit
        Set wordApp = Nothing
    End If
Next cell

' 清理对象
Set OutlookApp = Nothing
End Sub

Function IsValidEmail(emailAddress As String) As Boolean
    ' 使用正则表达式检查邮箱地址是否有效
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "^[\w\.-]+@[a-zA-Z\d\.-]+\.[a-zA-Z]{2,}$"
    IsValidEmail = regex.Test(emailAddress)
End Function

关键修改点 #

• 使用Range对象逐段插入文本，每插入一段后选中该段落单独设置格式，避免格式覆盖
• 用rng.Collapse 0将光标移到当前内容末尾，确保新文本追加在最后
• 对每一段落单独设置字体大小、加粗状态和对齐方式，保证格式只作用于目标段落

内容的提问来源于stack exchange，提问作者Cleverito