Найти заголовок vba word

You mean like this createOutline function (which actually copy all headings from a source word document into a new word document):

(I believe the astrHeadings = docSource.GetCrossReferenceItems(wdRefTypeHeading) function is the key in this program, and should allow you to retrieve what you are asking for)

Public Sub CreateOutline()
    Dim docOutline As Word.Document
    Dim docSource As Word.Document
    Dim rng As Word.Range
    
    Dim astrHeadings As Variant
    Dim strText As String
    Dim intLevel As Integer
    Dim intItem As Integer
        
    Set docSource = ActiveDocument
    Set docOutline = Documents.Add
    
    ' Content returns only the main body of the document, not the headers/footer.        
    Set rng = docOutline.Content
    ' GetCrossReferenceItems(wdRefTypeHeading) returns an array with references to all headings in the document
    astrHeadings = docSource.GetCrossReferenceItems(wdRefTypeHeading)
    
    For intItem = LBound(astrHeadings) To UBound(astrHeadings)
        ' Get the text and the level.
        strText = Trim$(astrHeadings(intItem))
        intLevel = GetLevel(CStr(astrHeadings(intItem)))
        
        ' Add the text to the document.
        rng.InsertAfter strText & vbNewLine
        
        ' Set the style of the selected range and
        ' then collapse the range for the next entry.
        rng.Style = "Heading " & intLevel
        rng.Collapse wdCollapseEnd
    Next intItem
End Sub

Private Function GetLevel(strItem As String) As Integer
    ' Return the heading level of a header from the
    ' array returned by Word.
    
    ' The number of leading spaces indicates the
    ' outline level (2 spaces per level: H1 has
    ' 0 spaces, H2 has 2 spaces, H3 has 4 spaces.
        
    Dim strTemp As String
    Dim strOriginal As String
    Dim intDiff As Integer
    
    ' Get rid of all trailing spaces.
    strOriginal = RTrim$(strItem)
    
    ' Trim leading spaces, and then compare with
    ' the original.
    strTemp = LTrim$(strOriginal)
    
    ' Subtract to find the number of
    ' leading spaces in the original string.
    intDiff = Len(strOriginal) - Len(strTemp)
    GetLevel = (intDiff / 2) + 1
End Function

UPDATE by @kol on March 6, 2018

Although astrHeadings is an array (IsArray returns True, and TypeName returns String()) I get a type mismatch error when I try to access its elements in VBScript (v5.8.16384 on Windows 10 Pro 1709 16299.248). This must be a VBScript-specific problem, because I can access the elements if I run the same code in Word’s VBA editor. I ended up iterating the lines of the TOC, because it works even from VBScript:

For Each Paragraph In Doc.TablesOfContents(1).Range.Paragraphs
  WScript.Echo Paragraph.Range.Text
Next

Unfortunately, table captions are not actually associated with their tables through the Word Object Model. When a table caption is created, it is just text placed in a separate Paragraph object.

So, the short answer is that no, there is no good way to find the caption for a given table.

I did write some code that may help you though. It basically iterates through all Paragraph objects in the document and looks for the «Caption» style (alternatively, you could look for text formatted «Table #:», or whatever you’d like). If the very next Paragraph contains tables, it places the text of the caption into the first cell of the first table found.

    Dim p As Paragraph
    Dim lastParagraphWasCaption As Boolean
    Dim lastCaptionText As String
    lastParagraphWasCaption = False

    For Each p In ActiveDocument.Paragraphs
        If lastParagraphWasCaption And p.Range.Tables.Count > 0 Then
            p.Range.Tables(1).Cell(1, 1).Range.Text = lastCaptionText
        End If

        If p.Range.Style = "Caption" Then
            lastParagraphWasCaption = True
            lastCaptionText = p.Range.Text
        Else
            lastParagraphWasCaption = False
        End If
    Next

Keep in mind that this is just an example of how you could tie together a caption with its table. With that said, it is not a very reliable method and I would not recommend using it unless you absolutely need to because table captions could presumably not have the caption styling, or there could be caption styling on something that isn’t a caption, etc.

First things first, let’s clean everything up.

Proper descriptive naming, proper validation variables, making the code clear and obvious about what’s happening where

Public Function GetHeadingFromStyle(ByVal styleToFind As String) As String
    '/ Iteratively checks the style of all paragraphs, starting at the current selection and working towards the start of the document.
    '/ If the style matches the inputStyle, return the text of the paragraph.
    '/ If no match is found, return "No heading Found"

    Const NO_HEADING_FOUND_TEXT As String = "No heading Found"

    Dim currentRange As Range
    currentRange = Selection.Range

    Dim wholeDocumentSearched As Boolean
    wholeDocumentSearched = False

    Dim headingFound As Boolean
    headingFound = False

    Do Until headingFound Or wholeDocumentSearched
        Set currentRange = currentRange.Previous(wdParagraph, 1)

        headingFound = (currentRange.Style = styleToFind)
        wholeDocumentSearched = ActiveDocument.Range(0, currentRange.Paragraphs(1).Range.End).Paragraphs.Count = 0
    Loop

    If headingFound Then
        GetHeadingFromStyle= currentRange.Paragraphs(1).Range.Text
    Else
        GetHeadingFromStyle= NO_HEADING_FOUND_TEXT
    End If

End Function

Okay, here’s where we’re taking so much time:

Do Until headingFound Or wholeDocumentSearched
    Set currentRange = currentRange.Previous(wdParagraph, 1)

    headingFound = (currentRange.Style = styleToFind)
    wholeDocumentSearched = ActiveDocument.Range(0, currentRange.Paragraphs(1).Range.End).Paragraphs.Count = 0
Loop

You mentioned in your previous question that these documents could be 1,000+ pages. Iteratively looping over something that huge is going to be slow. What we need is some kind of map/lookup.

I’m not very familiar with the Word object model, so there might be something blindingly obvious/easy I’m missing. That aside, here are ideas:

Idea #1:

Map the entire document once and then reference the map. This will mean having a slow execution once, and then all subsequent searches should be lightning fast.

Note, this only works if the document structure is not going to change between some number of iterations (5-10 would be a good minimum). Because as soon as a new paragraph gets inserted/deleted/moved, our entire map is going to be inaccurate.

So, something like this:

Option Explicit

Public ParagraphStyles As Variant
Public Const INDEX_INDEX2 As Long = 1 '/ index2 to distinguish between dimensions of the array
Public Const STYLE_INDEX2 As Long = 2

Public Sub SetupDocumentSearch()

    ParagraphStyles = MapParagraphStyles

    '/ Call Main sub here

End Sub

Public Function MapParagraphStyles(ByRef targetDocument As Document)
    '/ Loop through the document and, for each paragraph:
    '/ Add the paragraph Index and Style to an array

    With targetDocument

        Dim styleMap As Variant
        ReDim styleMap(1 To .Paragraphs.Count, 1 To 2)

        Dim currentParagraph As Range
        Dim paragraphCounter As Long

        For paragraphCounter = 1 To .Paragraphs.Count

            styleMap(paragraphCounter, INDEX_INDEX2) = indexcounter
            styleMap(paragraphCounter, STYLE_INDEX2) = .Paragraphs(indexcounter).Style

        Next paragraphCounter

    End With

    MapParagraphStyles = styleMap

End Function

Then we can loop over an array searching for our style. Iterating over arrays is orders of magnitude faster than working with high-level objects like documents:

Public Function GetHeadingFromStyle(ByVal styleToFind As String) As String
    '/ Iteratively checks the style of all paragraphs, starting at the current selection and working towards the start of the document.
    '/ If the style matches the inputStyle, return the text of the paragraph.
    '/ If no match is found, return "No heading Found"

    Const NO_HEADING_FOUND_TEXT As String = "No heading Found"

    Dim paragraphIndex As Long
    paragraphIndex = ActiveDocument.Range(0, Selection.Paragraphs(1).Range.End).Paragraphs.Count

    Dim wholeDocumentSearched As Boolean
    wholeDocumentSearched = False

    Dim headingFound As Boolean
    headingFound = False

    Do Until headingFound Or wholeDocumentSearched
        paragraphIndex = paragraphIndex - 1

        headingFound = ParagraphStyles(paragraphIndex, STYLE_INDEX2) = styleToFind
        wholeDocumentSearched = (paragraphIndex = 1)
    Loop

    If headingFound Then
        GetHeadingFromStyle = ActiveDocument.Paragraphs(paragraphIndex).Range.Text
    Else
        GetHeadingFromStyle = NO_HEADING_FOUND_TEXT
    End If

End Function

Вернуться в VBA

Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 2