VBA word 自动创建标题索引表

情缘侠

[Visual Basic] 纯文本查看 复制代码

Sub 页码获取()
    Dim para As Paragraph
    Dim headingText As String
    Dim startPage As Long
    Dim endPage As Long
    Dim tbl As Table
    Dim row As Integer
    Dim doc As Document
    
    ' 设置文档对象
    Set doc = ActiveDocument
    
    ' 在文档末尾插入一个新的表格
    Selection.EndKey Unit:=wdStory
    Selection.TypeParagraph
    Set tbl = doc.Tables.Add(Range:=Selection.Range, NumRows:=1, NumColumns:=2)
    tbl.cell(1, 1).Range.Text = "标题名称"
    tbl.cell(1, 2).Range.Text = "所在页码"
     ' 提示用户输入标题名称
    selectedHeading = InputBox("请输入您要查找的标题名称：", "选择标题名称")
        If selectedHeading = "" Then
        MsgBox "您没有输入标题名称。"
        Exit Sub
    End If
    ' 设置表格标题行样式
    tbl.Rows(1).Range.Font.Bold = True
    tbl.Rows(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
        
    row = 2 ' 表格的初始行
    
    ' 遍历所有段落
    For Each para In doc.Paragraphs
        ' 检查是否为标题1
        If para.Style = selectedHeading Then
            headingText = para.Range.Text
            headingText = Trim(headingText) ' 去除多余的换行符或空格

            ' 获取该标题的起始页码
            startPage = para.Range.Information(wdActiveEndPageNumber)
            
            ' 查找该标题下一个“标题1”或者文档末尾的页码范围
            If para.Next() Is Nothing Then
                endPage = startPage
            Else
                endPage = para.Next.Range.Information(wdActiveEndPageNumber)
            End If
            
            ' 插入标题和页码范围到表格
            tbl.Rows.Add
            tbl.cell(row, 1).Range.Text = headingText
            tbl.cell(row, 2).Range.Text = startPage & " - " & endPage
            row = row + 1
        End If
    Next para
End Sub

mormas

文档较大时可能速度较慢，添加进度条和取消机制

[Visual Basic] 纯文本查看 复制代码

Sub CreateHeadingIndexTableWithProgress()
    Dim doc As Document
    Dim newDoc As Document
    Dim table As Table
    Dim headingRange As Range
    Dim headingText As String
    Dim headingLevel As Integer
    Dim i As Long
    Dim rowIndex As Long
    Dim totalParagraphs As Long
    Dim progress As Single
    Dim cancelFlag As Boolean
    
    ' 获取当前文档
    Set doc = ActiveDocument
    totalParagraphs = doc.Paragraphs.Count
    
    ' 创建进度条窗体
    Dim progressForm As Object
    Set progressForm = CreateProgressForm()
    progressForm.Show vbModeless
    
    ' 创建一个新文档用于存放标题索引表
    Set newDoc = Documents.Add
    newDoc.Content.Text = "标题索引表" & vbCrLf & vbCrLf
    newDoc.Content.InsertAfter Text:="级别" & vbTab & "标题内容" & vbCrLf
    
    ' 遍历文档中的所有段落
    For i = 1 To totalParagraphs
        ' 更新进度条
        progress = i / totalParagraphs
        progressForm.UpdateProgress progress, "正在处理段落 " & i & " / " & totalParagraphs
        
        ' 检查是否取消
        If progressForm.CancelRequested Then
            cancelFlag = True
            Exit For
        End If
        
        ' 检查段落是否使用了标题样式
        If doc.Paragraphs(i).Range.Style.Type = wdStyleTypeParagraph Then
            If Left(doc.Paragraphs(i).Range.Style.NameLocal, 5) = "标题" Then
                ' 获取标题级别
                headingLevel = Val(Mid(doc.Paragraphs(i).Range.Style.NameLocal, 6))
                
                ' 获取标题文本
                headingText = doc.Paragraphs(i).Range.Text
                headingText = Left(headingText, Len(headingText) - 1) ' 去掉末尾的换行符
                
                ' 将标题级别和内容写入新文档
                newDoc.Content.InsertAfter Text:=headingLevel & vbTab & headingText & vbCrLf
            End If
        End If
    Next i
    
    ' 关闭进度条窗体
    Unload progressForm
    
    ' 如果用户取消操作
    If cancelFlag Then
        newDoc.Close SaveChanges:=wdDoNotSaveChanges
        MsgBox "操作已取消。", vbInformation
        Exit Sub
    End If
    
    ' 将内容转换为表格
    newDoc.Content.ConvertToTable Separator:=vbTab, NumColumns:=2
    
    ' 设置表格样式
    Set table = newDoc.Tables(1)
    With table
        .Style = "网格表"
        .Columns(1).Width = 50
        .Columns(2).Width = 400
        .Rows(1).Range.Font.Bold = True ' 表头加粗
    End With
    
    ' 提示完成
    MsgBox "标题索引表已生成！", vbInformation
End Sub

Function CreateProgressForm() As Object
    Dim userForm As Object
    Dim progressBar As Object
    Dim cancelButton As Object
    Dim label As Object
    
    ' 创建用户窗体
    Set userForm = VBA.UserForms.Add("ProgressForm")
    With userForm
        .Caption = "生成标题索引表"
        .Width = 300
        .Height = 120
    End With
    
    ' 添加标签
    Set label = userForm.Controls.Add("Forms.Label.1", "ProgressLabel")
    With label
        .Caption = "正在初始化..."
        .Left = 10
        .Top = 10
        .Width = 280
        .Height = 20
    End With
    
    ' 添加进度条
    Set progressBar = userForm.Controls.Add("Forms.ProgressBar.1", "ProgressBar")
    With progressBar
        .Left = 10
        .Top = 40
        .Width = 280
        .Height = 20
    End With
    
    ' 添加取消按钮
    Set cancelButton = userForm.Controls.Add("Forms.CommandButton.1", "CancelButton")
    With cancelButton
        .Caption = "取消"
        .Left = 110
        .Top = 70
        .Width = 80
        .Height = 30
    End With
    
    ' 设置取消标志
    userForm.CancelRequested = False
    
    ' 绑定取消按钮事件
    With cancelButton
        .OnAction = "CancelProgress"
    End With
    
    ' 返回用户窗体
    Set CreateProgressForm = userForm
End Function

Sub CancelProgress()
    Dim progressForm As Object
    Set progressForm = VBA.UserForms("ProgressForm")
    progressForm.CancelRequested = True
    progressForm.Hide
End Sub

lidongqi

如何用不会呀？

小能维尼

通过 遍历所有段落 的方法，定位标题，效率是不是太低了
有没有小老哥知道，直接获取标题对象的方法？
我感觉是有这种方法的呀，实在是不知道

xors

VBA会的都是大佬啊

tydzjing

先存一下，以免用的时候找不到

aiguohou

大佬，学习了