用VBA将尾注改为脚注

epub和mobi等基于HTML的格式成为电子书流行格式后，纸质书时代常采用的脚注在这种电子书里就消失了，注释通常采用章节末尾或文章末尾的尾注形式。因为我喜欢某种字体，而这种字体不知道是什么原因，即使内嵌到epub中也没法使用。因此，我经常将epub文件转换为pdf文件。像我这种养成了阅读过程中随时查阅注释习惯的人，在平板上阅读pdf文件，看脚注比看尾注就方便很多了，将尾注转换成脚注就成了刚需。

如果要靠人工将尾注一条条改成脚注，那简直就是受刑，要知道一本书注释数量经常几百条上千条。好在只要是有规律的工作，总可以求助万能的VBA，可以将epub先转换成word，在word中用VBA将尾注转换成脚注后再转换成pdf。下面就是将尾注转换为脚注的VBA。

Sub 尾注改脚注()

    Dim Text, FootnoteText As String, Found As Boolean, Myrange As Range
    
    Dim i, EndOfSelectionPara, ParaIndex, notes As Long
    
    Found = True
    '书籍中尾注数量太多的话宏的运行时间太长，用多次运行的方式修改较好。
    '这里设置每次运行最多修改1000条尾注
    notes = 1000
    i = 0
    
    Application.ScreenUpdating = False
    
    EndOfSelectionPara = Selection.Paragraphs(1).Range.End
    Set Myrange = ActiveDocument.Range(0, EndOfSelectionPara)
    ParaIndex = Myrange.Paragraphs.Count
    
    
    ActiveDocument.Paragraphs(ParaIndex).Range.Select
    Selection.MoveLeft
    '改变文档视图，避免移动段落时总是自动重新分页
    ActiveWindow.View.Type = wdNormalView

LoopAgain:

    While i <= notes
        Selection.Find.ClearFormatting
        '查找注释编号，适用于格式为(number)或[number]形式的编号。
        '如果编号格式为其他形式，需修改正则表达式
        With Selection.Find
            .Text = "[\(\[][0-9]{1,}[\)\]]"
            .MatchWildcards = True
            .Forward = True
        End With
        '没有编号了，准备结束
        Found = Selection.Find.Execute
        If Not Found Then
            GoTo ReadyToStop
        End If
        '记录编号，作为寻找相应注释文本的关键字
        Text = Selection.Range.Text
        
        '查找注释段落，找不到相应编号的尾注，则重新循环，找下一个编号
        Selection.MoveRight
        With Selection.Find
            .Text = Text
            .MatchWildcards = False
            .Forward = True
        End With
        Found = Selection.Find.Execute
        '找不到对应的注释就不管这个编号了，处理下一个编号
        If Not Found Then
            GoTo LoopAgain
        End If
        '记录注释文本。从注释编号后一个位置至段落末尾视为注释文本
        FootnoteText = Mid(Selection.Paragraphs(1).Range.Text, Len(Text) + 1, _
            Len(Selection.Paragraphs(1).Range.Text) - Len(Text) - 1)
        '删除注释段落
        Selection.Paragraphs(1).Range.Delete
        
        '重新向前找到注释编号，删除该编号并在相应位置添加脚注
        Selection.MoveLeft
        With Selection.Find
            .Text = Text
            .MatchWildcards = False
            .Forward = False
        End With
        Selection.Find.Execute
        Selection.Range.Delete
        EndOfSelectionPara = Selection.Paragraphs(1).Range.End
        Set Myrange = ActiveDocument.Range(0, EndOfSelectionPara)
        ParaIndex = Myrange.Paragraphs.Count
        With Selection
            With .FootnoteOptions
                .Location = wdBottomOfPage
                .StartingNumber = 1
                .NumberStyle = 28
                .NumberingRule = wdRestartPage
                .LayoutColumns = 0
            End With
            .Footnotes.Add Range:=Selection.Range, Reference:=""
        End With
        Selection.TypeText (FootnoteText)       
        
        
        '将光标由脚注区域重新移动到正文中上一次插入注释的位置之后
        ActiveDocument.Paragraphs(ParaIndex).Range.Select
        Selection.MoveLeft
        i = i + 1
    Wend
ReadyToStop:
    Application.ScreenUpdating = True
    ActiveWindow.View.Type = wdPrintView
End Sub

这个宏成功实现目标的前提是注释编号格式要一致，每条注释只能有一个段落（若有多个段落只有第一段会被移动到脚注中，其余段落会在原来位置）。就我处理过的epub电子书，只有极少数注释会超过一个段落，可以在VBA处理完后可以快速浏览一下，有必要时对照原始epub文件做下手工修改，工作量一般也不大。