使用VBA按照指定格式快速整理多段落文档（邮件）

实例需求：客户沟通邮件，需要整理为指定格式，然后粘贴到CRM系统中。

通常用户操作分为如下几步：
1.拷贝邮件
2.粘贴到记事本（或者其他文本编辑器）
3.整理格式
4.拷贝文本粘贴到CRM系统

由于邮件正文样式各不相同，上述步骤中，步骤3操作最为复杂，使用VBA代码可以简化这个操作。

示例邮件如下：

From: sender@emailaddress.com
CC: cc1@emailaddress.com; cc2@emailaddress.org
SUBJECT: please update file notes to including the following

Good morning,

There are 5 permanent portals to the pool line and the request was only for 3, so we sent a request for repair of two and this should be completed anytime on any date, 2024. 

Thank you!

格式要求：

• 将From行和CC行合并为一个段落
• 保留SUBJECT行和最后的行（Thank you!）不变
• 其余部分合并为单个段落，并且按照指定字符宽度（例如：46个字符，包含空格和标点符号）重新划分段落

整理后的格式如下。

From: sender@emailaddress.com CC: cc1@emailaddress.com; cc2@emailaddress.org
SUBJECT: please update file notes to including the following
Good morning, There are 5 permanent portals 
to the pool line and the request was only for 
3, so we sent a request for repair of two and 
this should be completed anytime on any date, 
2024.  
Thank you!

为了便于演示，示例代码将原始邮件保存在表格中的第一个单元格中，整理后的内容写入第二个单元格中。

示例代码如下。

Sub FormatMultipleLines()
    Dim oTab As Table, rngBody As Range, aTxt, iLen As Long
    Dim sLine As String, sTxt As String, i As Long
    Const CHAR_WIDTH = 46
    Set oTab = ActiveDocument.Tables(1)
    oTab.Range.Cells(1).Range.Copy 
    oTab.Range.Cells(2).Range.Paste
    With oTab.Range.Cells(2).Range.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "^p^p"
        .Replacement.Text = "^p"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
        .Text = "^pCC"
        .Replacement.Text = " CC"
        .Execute Replace:=wdReplaceAll
        If .Execute(FindText:="SUBJECT") Then
            Set rngBody = .Parent.Duplicate
        End If
    End With
    If Not rngBody Is Nothing Then
        rngBody.MoveStart Word.wdParagraph, 1
        rngBody.End = oTab.Range.Cells(2).Range.End
        rngBody.MoveEnd Word.wdParagraph, -1
        aTxt = Split(Replace(rngBody.Text, vbCr, " "))
        For i = 0 To UBound(aTxt)
            If Len(sLine & " " & aTxt(i)) <= CHAR_WIDTH Then
                sLine = sLine & " " & aTxt(i)
            Else
                If sTxt = "" Then
                    sTxt = sLine & " "
                Else
                    sTxt = sTxt & vbCr & sLine & " "
                End If
                sLine = aTxt(i)
            End If
        Next
        sTxt = sTxt & vbCr & sLine
        rngBody.Text = Mid(sTxt, 2) & vbCr
    End If
End Sub

【代码解析】
第5行代码设置行宽，即正文部分每行的最大字符数量。
第6行代码获取活动文档中第一个表格。
第7行代码拷贝第一个单元格中内容，模拟用户拷贝邮件。
第8行代码将邮件粘贴到第二个单元格中。
第9~30行代码在第二个单元格中进行查找替换。
第12~23行代码将删除邮件中的空行，其中^p为段落标记，注意此处只能处理单个空白段落。如果邮件中可能存在多个空白段落，那么需要多次循环查找替换。
第23行代码替换全部匹配项。
第24~26行代码将From行和CC行合并为一个段落，即将From行末尾的段落标记替换为空格。
第27行代码查找邮件中的SUBJECT，用于后续定位正文段落。
第28行代码获取相应的Range对象副本。
第32行代码将rngBoday起始位置向前移动一段，即SUBJECT之后一个段落的起始位置。
第33行代码将rngBoday结束位置设置为第二个单元格的结束位置。
第34行代码将rngBoday结束位置回退一段。
此时，rngBoday为需要重新断行的邮件正文部分。
第35行代码将邮件正文部分的换行符替换为空格，然后拆分为单词数组。
第36~47行代码循环遍历单词数组。
For循环过程中，sTxt为重新断行整理后的文本，sLine用于保存正在处理的当前行文本内容。
第37行代码用于判断当前行追加一个单词是否会超出列宽。
如果不超出列宽，那么第38行代码将单词追加到当前行，否则第40~44行代码将当前行内容sLine合并到sTxt中，第45行代码开始记录新的一行。
第48行代码将最后一行内容合并到sTxt中。
第49行代码更新第二个单元格中的邮件正文内容。

在Word中运行代码，结果如下图所示。