概述用word及vba代码作为古籍的排版工具。实现以下功能简单的古籍筒子页基础竖版A4排版。标点符号全部替换为句号本文以中文句号○为例且不占文字位置目前每列18个字。最终的A4纸打印、对折及装订后的效果如下图。步骤注意在操作之前关闭所有其他word文档以避免误操作。如有误操作本人概不负责。先处理好古籍原文。a、在TXT文档里把内部所有的标点符合全部转换为“中文顿号、”这一步必须认真。替换时候可能会出现紧挨着的两个顿号都需要替换。这一步的目标是把内部所有的现代标点符号全部转换为单个的顿号。b、将内部的所有空行、换行全部替换此步骤根据个人喜好也可以不替换。将TXT文档内的所有内容粘贴到基础模板里。注意书名、作者等的粘贴等。可以根据喜欢自已调整。应用以下代码对文档进行替换。将内部的所有顿号全部替换为句号。原文件及代码见链接https://pan.quark.cn/s/f22988fe4dbe 提取码U1J4代码如下 ***在操作之前关闭所有其他word文档以避免误操作。如有误操作本人概不负责。*** 长注释的就是可以根据自己的实际情况修改的地方 使用方法将以下代码复制到word的模块之中AltF11,在本文档下添加一个模块具体操作请自行搜索操作过程修改如下参数也可直接运行先看看效果在修改然后点击运行即可。 Sub SmartReplaceWithTextBox() Dim searchText As String, replaceText As String Dim rng As Range Dim txtBox As Shape Dim found As Boolean Dim pageNum As Long Dim originalWidth As Single, originalHeight As Single found True Dim n As Integer, m As Integer n 0 计数器用 一次替换m个尽量设置小一些 1、可以避免死机 2、可以随时查看替换是否正确。 m 50 设置要查找和替换的文本 我先预处理原文本把里面所有的其他标点符号都替换成了中文顿号“、”这个顿号是占字符空间的。 然后再用本程序把原句号处理成“不占位置”的句号其实是插入了文本框。 searchText 、 replaceText 。 InputBox(请输入要替换为的文本, 替换文本, 。) If replaceText Then Exit Sub Do While found And n m 查找文本 Set rng ActiveDocument.Content 从光标处开始搜索 Set rng ActiveDocument.Range(Start:Selection.Range.Start, _ End:ActiveDocument.Content.End) With rng.Find .Text searchText .Forward True .Wrap wdFindStop .MatchCase False found .Execute End With If found Then n n 1 保存原始文字的大致尺寸用于文本框大小 originalWidth rng.Information(wdHorizontalPositionRelativeToPage) originalHeight rng.Information(wdVerticalPositionRelativeToPage) 获取当前位置信息 pageNum rng.Information(wdActiveEndPageNumber) Dim leftPos As Single, topPos As Single leftPos rng.Information(wdHorizontalPositionRelativeToPage) topPos rng.Information(wdVerticalPositionRelativeToPage) 创建临时范围来测量文本尺寸 Dim tempRng As Range Set tempRng ActiveDocument.Range(rng.Start, rng.End) tempRng.Text replaceText 获取临时文本的尺寸 Dim tempLeft As Single, tempTop As Single tempLeft tempRng.Information(wdHorizontalPositionRelativeToPage) tempTop tempRng.Information(wdVerticalPositionRelativeToPage) 删除临时文本使用文本框替换 tempRng.Delete 计算文本框大小基于临时文本的尺寸 Dim boxWidth As Single, boxHeight As Single boxWidth 15 默认宽度 boxHeight 15 默认高度 根据文本长度调整宽度 If Len(replaceText) 20 Then boxWidth 150 ElseIf Len(replaceText) 10 Then boxWidth 120 End If 添加文本框 这里调整标点的位置 这里调整标点的位置 Set txtBox ActiveDocument.Shapes.AddTextbox( _ msoTextOrientationHorizontal, _ leftPos 20, _ topPos - 10, _ boxWidth, _ boxHeight) 配置文本框 With txtBox .TextFrame.TextRange.Text replaceText 设置文本框样式 With .Fill .ForeColor.RGB RGB(255, 255, 255) 浅黄色背景 .Transparency 1 透明度 End With With .TextFrame .MarginLeft 0 .MarginTop 0 .MarginRight 0 .MarginBottom 0 End With .Line.ForeColor.RGB RGB(255, 255, 255) 深蓝色边框 .Line.Weight 1 .Line.Transparency 1 透明度 设置文字格式 With .TextFrame.TextRange .Font.Name 宋体 .Font.Size 10 .Font.Color RGB(0, 0, 0) .ParagraphFormat.Alignment wdAlignParagraphCenter End With 启用自动调整大小 .TextFrame.AutoSize False End With 移动到所在位置 rng.Select 删除原文字 rng.Delete MsgBox 文本已替换为文本框 vbCrLf _ 位置第 pageNum 页 vbCrLf _ 坐标( Round(leftPos, 1) , Round(topPos, 1) ) Else MsgBox 未找到文本 searchText vbCrLf 或已到达文档末尾。 End If Loop MsgBox n 个 ok End Sub零一个版本的标点替换此版本运行速度稍快些。 ***在操作之前关闭所有其他word文档以避免误操作。如有误操作本人概不负责。*** 长注释的就是可以根据自己的实际情况修改的地方 使用方法将以下代码复制到word的模块之中AltF11,在本文档下添加一个模块具体操作请自行搜索操作过程修改如下参数也可直接运行先看看效果在修改然后点击运行即可。 Sub SmartReplaceWithTextBox() Dim searchText As String, replaceText As String Dim rng As Range Dim txtBox As Shape Dim found As Boolean Dim pageNum As Long Dim originalWidth As Single, originalHeight As Single found True Dim n As Integer, m As Integer n 1 计数器用从0开始 一次替换m个尽量设置小一些 1、可以避免死机 2、可以随时查看替换是否正确。 m 30 设置要查找和替换的文本 我先预处理原文本把里面所有的其他标点符号都替换成了中文句号“。”这个句号是占字符空间的。 然后再用本程序把原句号处理成“不占位置”的句号其实是插入了文本框。 searchText 、 replaceText 。 InputBox(请输入要替换为的文本, 替换文本, 。) If replaceText Then Exit Sub Do While found And n m 查找文本 Set rng ActiveDocument.Content 从光标处开始搜索 Set rng ActiveDocument.Range(Start:Selection.Range.Start, _ End:ActiveDocument.Content.End) With rng.Find .Text searchText .Forward True .Wrap wdFindStop .MatchCase False found .Execute End With If found Then 保存原始文字的大致尺寸用于文本框大小 originalWidth rng.Information(wdHorizontalPositionRelativeToPage) originalHeight rng.Information(wdVerticalPositionRelativeToPage) 获取当前位置信息 pageNum rng.Information(wdActiveEndPageNumber) Dim leftPos As Single, topPos As Single leftPos rng.Information(wdHorizontalPositionRelativeToPage) topPos rng.Information(wdVerticalPositionRelativeToPage) 创建临时范围来测量文本尺寸 Dim tempRng As Range Set tempRng ActiveDocument.Range(rng.Start, rng.End) tempRng.Text replaceText 获取临时文本的尺寸 Dim tempLeft As Single, tempTop As Single tempLeft tempRng.Information(wdHorizontalPositionRelativeToPage) tempTop tempRng.Information(wdVerticalPositionRelativeToPage) 删除临时文本使用文本框替换 tempRng.Delete 移动到所在位置 rng.Select If n 1 Then 计算文本框大小基于临时文本的尺寸 Dim boxWidth As Single, boxHeight As Single boxWidth 15 默认宽度 boxHeight 15 默认高度 根据文本长度调整宽度 If Len(replaceText) 20 Then boxWidth 150 ElseIf Len(replaceText) 10 Then boxWidth 120 End If 添加文本框 这里调整标点的位置 这里调整标点的位置 Set txtBox ActiveDocument.Shapes.AddTextbox( _ msoTextOrientationHorizontal, _ leftPos 20, _ topPos - 10, _ boxWidth, _ boxHeight) 配置文本框 With txtBox .TextFrame.TextRange.Text replaceText 设置文本框样式 With .Fill .ForeColor.RGB RGB(255, 255, 255) 浅黄色背景 .Transparency 1 透明度 End With With .TextFrame .MarginLeft 0 .MarginTop 0 .MarginRight 0 .MarginBottom 0 End With .Line.ForeColor.RGB RGB(255, 255, 255) 深蓝色边框 .Line.Weight 1 .Line.Transparency 1 透明度 设置文字格式 With .TextFrame.TextRange .Font.Name 宋体这里自己改字体 .Font.Size 10 .Font.Color RGB(0, 0, 0) .ParagraphFormat.Alignment wdAlignParagraphCenter End With 启用自动调整大小 .TextFrame.AutoSize False End With 1、选择 txtBox.Select 2、复制 Selection.Copy Else 3. 粘贴到其他位置 粘贴 Dim myRange As Range Set myRange ActiveDocument.Range(Start:ActiveDocument.Content.End - 1, End:ActiveDocument.Content.End - 1) myRange.Paste rng.Paste ActiveDocument.Range(0, 0).PasteSpecial DataType:wdPasteShape 移动副本到新位置 With ActiveDocument.Shapes(ActiveDocument.Shapes.Count) .RelativeHorizontalPosition wdRelativeHorizontalPositionPage .Left leftPos 20 .Top topPos - 100 .TextFrame.TextRange.Text 副本 End With End If 删除原文字 rng.Delete MsgBox 文本已替换为文本框 vbCrLf _ 位置第 pageNum 页 vbCrLf _ 坐标( Round(leftPos, 1) , Round(topPos, 1) ) n n 1 Else MsgBox 未找到文本 searchText vbCrLf 或已到达文档末尾。 End If Loop MsgBox n 个 ok End Sub标点符号替换代码Sub FuhaoZhuanHuan() https://www.chinesecj.com/index.php Dim findArray As Variant Dim replaceArray As Variant Dim i As Integer 原始标点符号 findArray Array(, 、, 。, , , , ) 使用 ChrW() 方式输入 Unicode 直排标点符号 replaceArray Array(ChrW(HFE10), ChrW(HFE11), ChrW(HFE12), ChrW(HFE13), ChrW(HFE14), ChrW(HFE15), ChrW(HFE16)) 遍历替换 With Selection.Find .ClearFormatting .Replacement.ClearFormatting .Forward True .Wrap wdFindContinue .MatchWildcards False For i LBound(findArray) To UBound(findArray) .Text findArray(i) .Replacement.Text replaceArray(i) .Execute Replace:wdReplaceAll Next i End With MsgBox 标点符号转换完成, vbInformation, 转换完成 End Sub经验1、打印之前还需要校对标点会有部分标点位置不理想。有位置问题可选择后用鼠标或键盘上的上下左右箭头移动。2、先用导出或打印成PDF文件不同的软件效果会不一样打印输出一张看看实际效果后在全部打印输出。3、装订见https://www.sohu.com/a/861835986_5231874、例子中的字体为黄令东齐伋体QIJIC这个版本字全字体文件大概在40Mb左右网络上很多。5、鱼尾可以用word的绘图功能自制。绘制好后在模板的页眉内插入一个文本框将鱼尾粘贴进去即可。6、另一款免费软件https://blog.csdn.net/zhanghuanqian/article/details/158837010 还有一款复杂点但功能强大的开源软件https://github.com/shanleiguang/vRain非常强大的开源软件不用安装适用各大平台古籍工作室 https://github.com/dinstone/guji-studio-home缺点1、标点的位置正确率在90%。所以打印之前还需要仔细校对。2、灵活性稍差比如字体、字号大小需要自己调整才可以让字在竖格子。不同的字体的效果需要自己仔细调整。3、vba代码的运行效率较低耗时较长。(主要原因在于撤销功能一直在运行。)4、还不能按章节设置版心内容及鱼尾如果需要不同版心只能按部分单独编辑。5、未集成现代标点符号的替换功能。