在Word中快速实现同类内容应用“双行合一”格式

最近在将金瓶梅词话HTML版改编成带目录与页眉且支持交叉链接的Word文档过程中想将其中的批注处理成双行合一格式。书中共有三种批注眉批、侧批、夹批。HTML代码分别是下面这几种形式眉批span classcomment top-comment数语倔强中实含软媚认真处微带戏谑非有二十分奇妒二十分呆胆二十分灵心利口不能当机圆活如此。金莲真可人也。/span侧批span classcomment side-comment一语见血。/span夹批span classcomment pinch-comment敍述处好不扯淡在金莲又是绝正经事。/span直接将HTML源代码拷贝到Word中然后找DeepSeek生成一个宏进行处理以眉批为例Sub ConvertCommentToTwoLinesInOne() Dim doc As Document Dim regEx As Object Dim matches As Object Dim m As Object Dim rng As Range Dim content As String Dim startPos As Long Dim endPos As Long Set doc ActiveDocument Set regEx CreateObject(VBScript.RegExp) 设置正则表达式 regEx.Global True regEx.IgnoreCase True regEx.Pattern span classcomment top-comment(.?)/span 在文档文本中查找匹配 Dim docText As String docText doc.Content.Text Set matches regEx.Execute(docText) If matches.Count 0 Then MsgBox 未找到匹配的内容。, vbInformation Exit Sub End If 从后往前处理避免位置偏移 Dim i As Long For i matches.Count - 1 To 0 Step -1 Set m matches(i) 提取标签内的内容 content m.SubMatches(0) 计算标签内内容在文档中的起始位置相对于文档开头0-based m.FirstIndex 是整个匹配的起始位置 加上 span classcomment top-comment 的长度 startPos m.FirstIndex Len(span classcomment top-comment) endPos startPos Len(content) Word Range 的 Start/End 是 1-based Set rng doc.Range(Start:startPos 1, End:endPos 1) 删除整个匹配包括 span 标签只保留内容并设置双行合一 先把整个匹配替换为纯内容 Dim fullRng As Range Set fullRng doc.Range(Start:m.FirstIndex 1, End:m.FirstIndex Len(m.Value) 1) fullRng.Text content 重新获取替换后内容的 Range Set rng doc.Range(Start:m.FirstIndex 1, End:m.FirstIndex Len(content) 1) 设置双行合一 rng.TwoLinesInOne wdTwoLinesInOneEncloseInBrackets Next i MsgBox 处理完成共处理 matches.Count 处。, vbInformation End Sub宏的逻辑和功能似乎没错但是在我的Word 2016里运行的结果是眉批并没有变成“双行合一”格式。那么该怎么做如果先定义一个样式再应用到相关文字中由于双行合一无法像字体、字号那样直接定义在“样式”中所以也无法直接实现目标。不过Word的样式有“更新 XXX 以匹配所选内容”功能其中的XXX为所选择的样式名经试验先在部分文字上应用“双行合一”格式再在样式列表中选择要应用“双行合一”格式的样式名称右键点击选择“更新 XXX 以匹配所选内容”命令相关样式就会具有“双行合一”格式如图图一所以如果前面的DeepSeek的宏不起作用那么实现将该HTML文件中的批注改成双行合一格式最快捷的方法是第一步根据HTML标签的特点将相关内容应用为对应的样式例如将侧批内容span classcomment side-comment一语见血。/span应用为“侧批”样式如果相关样式不存在则创建它。完成这一步可以用VBA自动实现考虑到删除HTML标签用查找替换很容易做到所以为了简化VBA代码下面的宏没有像前面的DeepSeek的宏那样删除HTML标签因此下面的宏中相关正则表达式中的分组括号也可以不要Sub ConvertCommentToTwoLinesInOne() 先执行此宏将眉批、夹批、侧批内容分别指定对应的样式名 再在文档中修改相关内容的格式然后在样式列表中右键点击 相关样式选择“更新 样式名 以匹配所选内容” Dim doc As Document Dim regEx As RegExp Dim matches As Object Dim match As Object Dim tmpStyle As Style Dim rng As Range Dim docText As String Dim i As Long Set doc ActiveDocument docText doc.content.Text Set regEx New RegExp regEx.Global True 全局查找 regEx.IgnoreCase True 忽略大小写 1、处理眉批 1.1、设置正则表达式并查找匹配项 regEx.Pattern span classcomment top-comment(.?)/span Set matches regEx.Execute(docText) 1.2、准备眉批样式 Set tmpStyle Nothing On Error Resume Next Set tmpStyle doc.Styles(眉批) On Error GoTo 0 If tmpStyle Is Nothing Then 如果眉批样式不存在则基于正文样式创建一个字符类型的样式 Set tmpStyle doc.Styles.Add(Name:眉批, Type:wdStyleTypeCharacter) End If 1.3、从后往前处理匹配项避免位置偏移将每个匹配项设置为“眉批”样式。 On Error Resume Next If matches.Count 0 Then For i matches.Count - 1 To 0 Step -1 Set match matches(i) Set rng doc.Range(Start:match.firstIndex, End:match.firstIndex Len(match)) rng.Style doc.Styles(tmpStyle) Next i End If On Error GoTo 0 2、处理侧批 2.1、设置正则表达式并查找匹配项 regEx.Global True regEx.IgnoreCase True regEx.Pattern span classcomment side-comment(.?)/span Set matches regEx.Execute(docText) 2.2、准备侧批样式 Set tmpStyle Nothing On Error Resume Next Set tmpStyle doc.Styles(侧批) On Error GoTo 0 If tmpStyle Is Nothing Then 如果侧批样式不存在则基于正文样式创建一个字符类型的样式 Set tmpStyle doc.Styles.Add(Name:侧批, Type:wdStyleTypeCharacter) End If 2.3、从后往前处理匹配项避免位置偏移将每个匹配项设置为“侧批”样式。 On Error Resume Next If matches.Count 0 Then For i matches.Count - 1 To 0 Step -1 Set match matches(i) Set rng doc.Range(Start:match.firstIndex, End:match.firstIndex Len(match)) rng.Style doc.Styles(tmpStyle) Next i End If On Error GoTo 0 3、处理夹批 3.1、设置正则表达式并查找匹配项 regEx.Pattern span classcomment pinch-comment(.?)/span Set matches regEx.Execute(docText) 3.2、准备夹批样式 Set tmpStyle Nothing On Error Resume Next Set tmpStyle doc.Styles(夹批) On Error GoTo 0 If tmpStyle Is Nothing Then 如果夹批样式不存在则基于正文样式创建一个字符类型的样式 Set tmpStyle doc.Styles.Add(Name:夹批, Type:wdStyleTypeCharacter) End If 3.3、从后往前处理匹配项避免位置偏移将每个匹配项设置为“夹批”样式。 On Error Resume Next If matches.Count 0 Then For i matches.Count - 1 To 0 Step -1 Set match matches(i) Set rng doc.Range(Start:match.firstIndex, End:match.firstIndex Len(match)) rng.Style doc.Styles(tmpStyle) Next i End If On Error GoTo 0 MsgBox 处理完成!, vbInformation End Sub第二步通过指定样式查找到对应的内容然后选择这部分内容应用“双行合一”格式还可以实施修改文字颜色等操作如图图二说明图二第4步将“中文版式”工具误写成了“调整字符间距”工具请注意。第三步调出样式列表更新相关样式如图一。通过以上操作全文批注即都实现了双行夹批式排版。外一宏这个HTML文件中使用下面的标签实现了注音ruby鳏rtguān/rt/ruby下面的宏将这种注音在Word文档中也转换为注音Sub ConvertRubyToPhonetic() Dim doc As Document Dim regEx As RegExp Dim matches, match As Object Dim i As Long Dim rng As Range, content As String Dim phonetic As String Application.ScreenUpdating False Set doc ActiveDocument docText doc.content.Text Set regEx New RegExp regEx.Global True 全局查找 regEx.IgnoreCase True 忽略大小写 regEx.Pattern ruby(.?)rt(.?)/rt/ruby Set matches regEx.Execute(docText) On Error Resume Next If matches.Count 0 Then For i matches.Count - 1 To 0 Step -1 Set match matches(i) content match.SubMatches(0) 取文字 phonetic match.SubMatches(1) 取拼音 Set rng doc.Range(Start:match.FirstIndex, _ End:match.FirstIndex Len(match.Value)) rng.Text content 将匹配部分替换为纯内容 Set rng doc.Range(Start:match.FirstIndex, _ End:match.FirstIndex Len(content)) 重建区域 在区域中使用拼音向导 rng.PhoneticGuide Text:phonetic, Alignment: _ wdPhoneticGuideAlignmentOneTwoOne, Raise:13, FontSize:7 Next i End If On Error GoTo 0 MsgBox Done! Application.ScreenUpdating True End Sub