vba - 如何使用 VBA 按样式解析 MS Word 文档

Question

我正在尝试浏览 MSWord 文档并提取所有带有“问题”样式的段落，然后在文档末尾重新打印它们。任何建议都会非常有帮助 - 这就是我所拥有的（我认为所有步骤都在那里，我只是在 VBA 格式方面遇到了问题）。

Sub PullQuestions()
    '
    ' PullQuestions Macro
    '
    '
    Dim curPar As Paragraph

    ' numLists = ActiveDocument.ListParagraphs.Count

    ' reprints each question on a new line at end of document'
    For Each curPar In ActiveDocument.Paragraphs
        If curPar.Selection.Style = "Question" Then
            Selection.TypeText (curPar & vbCr)
        End If
    End Sub

Answer 1

我想你会发现搜索功能对你来说可能更有效。以下代码将搜索文档并将值放入数组中，然后将它们放在文档的末尾。它还将设置段落样式以反映原始样式。请注意，如果您在文档末尾使用应用于输出的样式继续运行它，您将得到一个令人讨厌的输出。

我已经评论得很好，但如果它没有意义，请告诉我。

Sub SearchStyles()
    Dim iCount As Integer, iArrayCount As Integer, bFound As Boolean

    'We'll store our result in an array so set this up (assume 50 entries)
    ReDim sArray(1 To iArrayCount) As String
    iArrayCount = 50

    'State your Style type
    sMyStyle = "Heading 1"

    'Always start at the top of the document
    Selection.HomeKey Unit:=wdStory

    'Set your search parameters and look for the first instance
    With Selection.Find
        .ClearFormatting
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchFuzzy = False
        .MatchWildcards = True
        .Style = sMyStyle
        .Execute
    End With

    'If we find one then we can set off a loop to keep checking
    'I always put a counter in to avoid endless loops for one reason or another
    Do While Selection.Find.Found = True And iCount < 1000
        iCount = iCount + 1

        'If we have a result then add the text to the array
        If Selection.Find.Found Then
            bFound = True

            'We do a check on the array and resize if necessary (more efficient than resizing every loop
            If ii Mod iArrayCount = 0 Then ReDim Preserve sArray(1 To UBound(sArray) + iArrayCount)
            sArray(iCount) = Selection.Text

            'Reset the find parameters
            Selection.Find.Execute
        End If
    Loop

    'Finalise the array to the actual size
    ReDim Preserve sArray(1 To iCount)

    If bFound Then
        'Output to the end of the document
        ActiveDocument.Bookmarks("\EndOfDoc").Range.Select
        Selection.TypeParagraph
        For ii = LBound(sArray) To UBound(sArray)
            Selection.Text = sArray(ii)
            Selection.Range.Style = sMyStyle
            Selection.MoveRight wdCharacter, 1
            If ii < UBound(sArray) Then Selection.TypeParagraph
        Next ii
    End If
End Sub