VBA: powrót numer strony z selection.find pomocą tekstu z tablicy

Question

(UWAGA: Patrz poniżej rozwiązania.)

I zostały próbuje odebrać numery stron z różnych stron, które znajdują się na nagłówki w dokumencie programu Word przy użyciu VBA. Mój aktualny kod zwraca 2 lub 3, a nie poprawnie powiązane numery stron, w zależności od tego, gdzie i jak go używam w głównej podsieci.

astrHeadings = docSource.GetCrossReferenceItems(wdRefTypeHeading) 

For Each hds In astrHeadings 
     docSource.Activate 
     With Selection.Find 
      .Text = Trim$(hds) 
      .Forward = True 
      MsgBox hds & ":" & Selection.Information(wdActiveEndPageNumber), vbOKOnly 
     End With 
     Selection.Find.Execute 
Next 

docSource jest dokumentem Test Mam skonfigurować z 10 pozycjami na 3 stronach. Mam nagłówki pobrane z metody getCrossReferenceItems w użyciu później w moim kodzie.

Próbuję przeprowadzić pętlę wyników z metody getCrossReferenceItems i użyć ich w obiekcie Find na docSource i ustalić, na której stronie znajduje się wynik. Numery stron zostaną następnie użyte w ciągu znaków później w moim kodzie. Ten ciąg plus numer strony zostanie dodany do innego dokumentu, który jest tworzony na początku mojego głównego subu, wszystko inne działa traktować, ale ten segment kodu.

Idealnie, czego potrzebuję, aby ten segment zrobić, to wypełnić drugą tablicę z powiązanymi numerami stron z każdego wyniku wyszukiwania.

Problemy rozwiązywane

Thanks Kevin byliście bardzo pomocne tutaj, teraz mam dokładnie to, co muszę z wyjścia tego Sub.

docSource to dokument testowy, który utworzyłem z 10 nagłówkami na 3 strony. docOutline to nowy dokument, który będzie działał jako dokument spisu treści.

musiałem użyć tego Sub nad wbudowane funkcje TOC programu Word, ponieważ:

1. Mam wiele dokumentów w celu włączenia, mogę użyć pola RD obejmować te jednak

2. I mieć kolejny numer Sub, który generuje niestandardową numerację stron dziesiętnych w każdym dokumencie 0.0.0 (przedstawiciel sekcji.sekcja.page), który, aby cały pakiet dokumentów miał sens, musi być uwzględniony w spisie treści jako numery stron. Prawdopodobnie istnieje inny sposób robienia tego, ale wymyśliłem puste funkcje wbudowane w Worda.

Ta funkcja stanie się częścią mojej strony o numeracji Sub. Obecnie jestem 3/4 drogi do ukończenia tego małego projektu, ostatni kwartał powinien być prosty.

poprawiony i oczyszczony ostateczny kod

Public Sub CreateOutline() 
' from http://stackoverflow.com/questions/274814/getting-the-headings-from-a-word-document 
    Dim docOutline As Word.Document 
    Dim docSource As Word.Document 
    Dim rng As Word.Range 
    Dim strFootNum() As Integer 
    Dim astrHeadings As Variant 
    Dim strText As String 
    Dim intLevel As Integer 
    Dim intItem As Integer 
    Dim minLevel As Integer 
    Dim tabStops As Variant 

    Set docSource = ActiveDocument 
    Set docOutline = Documents.Add 

    minLevel = 5 'levels above this value won't be copied. 

    ' Content returns only the 
    ' main body of the document, not 
    ' the headers and footer. 
    Set rng = docOutline.Content 
    astrHeadings = docSource.GetCrossReferenceItems(wdRefTypeHeading) 

    docSource.Select 
    ReDim strFootNum(0 To UBound(astrHeadings)) 
    For i = 1 To UBound(astrHeadings) 
     With Selection.Find 
      .Text = Trim(astrHeadings(i)) 
      .Wrap = wdFindContinue 
     End With 

     If Selection.Find.Execute = True Then 
      strFootNum(i) = Selection.Information(wdActiveEndPageNumber) 
     Else 
      MsgBox "No selection found", vbOKOnly 
     End If 
     Selection.Move 
    Next 

    docOutline.Select 

    With Selection.Paragraphs.tabStops 
     '.Add Position:=InchesToPoints(2), Alignment:=wdAlignTabLeft 
     .Add Position:=InchesToPoints(6), Alignment:=wdAlignTabRight, Leader:=wdTabLeaderDots 
    End With 

    For intItem = LBound(astrHeadings) To UBound(astrHeadings) 
     ' Get the text and the level. 
     ' strText = Trim$(astrHeadings(intItem)) 
     intLevel = GetLevel(CStr(astrHeadings(intItem))) 
     ' Test which heading is selected and indent accordingly 
     If intLevel <= minLevel Then 
       If intLevel = "1" Then 
        strText = " " & Trim$(astrHeadings(intItem)) & vbTab & "1" & "." & "2" & "." & strFootNum(intItem) & vbCr 
       End If 
       If intLevel = "2" Then 
        strText = " " & Trim$(astrHeadings(intItem)) & vbTab & "1" & "." & "2" & "." & strFootNum(intItem) & vbCr 
       End If 
       If intLevel = "3" Then 
        strText = "  " & Trim$(astrHeadings(intItem)) & vbTab & "1" & "." & "2" & "." & strFootNum(intItem) & vbCr 
       End If 
       If intLevel = "4" Then 
        strText = "   " & Trim$(astrHeadings(intItem)) & vbTab & "1" & "." & "2" & "." & strFootNum(intItem) & vbCr 
       End If 
       If intLevel = "5" Then 
        strText = "   " & Trim$(astrHeadings(intItem)) & vbTab & "1" & "." & "2" & "." & strFootNum(intItem) & vbCr 
       End If 
      ' Add the text to the document. 
      rng.InsertAfter strText & vbLf 
      docOutline.SelectAllEditableRanges 
      ' tab stop to set at 15.24 cm 
      'With Selection.Paragraphs.tabStops 
      ' .Add Position:=InchesToPoints(6), _ 
      ' Leader:=wdTabLeaderDots, Alignment:=wdAlignTabRight 
      ' .Add Position:=InchesToPoints(2), Alignment:=wdAlignTabCenter 
      'End With 
      rng.Collapse wdCollapseEnd 
     End If 
    Next intItem 
End Sub 

Private Function GetLevel(strItem As String) As Integer 
    ' from http://stackoverflow.com/questions/274814/getting-the-headings-from-a-word-document 
    ' 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 

Kod ten jest obecnie produkuje (Jaki powinien być według mojego opisu, pozycje w teście-doc.docx):

This is heading one     1.2.1 
    This is heading two    1.2.1 
    This is heading two.one   1.2.1 
    This is heading two.three  1.2.1 
This is heading one.two    1.2.2 
    This is heading three   1.2.2 
     This is heading four   1.2.2 
      This is heading five  1.2.2 
      This is heading five.one 1.2.3 
      This is heading five.two 1.2.3 

W Oprócz tego, rozwiązałem problem przełączania ActiveDocument za pomocą instrukcji docSource.select i docOutline.Select zamiast używać .Active.

Dzięki znowu Kevin, bardzo mile widziane :-)

Phil

Answer 1

Wygląda Selection.Information(wdActiveEndPageNumber) będą pasowały, chociaż jest to w złym miejscu kodu komunikatu. Umieścić tę linię po wykonać znalezienia tak:

For Each hds In astrHeadings 
    docSource.Activate 
    With Selection.Find 
     .Text = Trim$(hds) 
     .Forward = True 
    End With 
    Selection.Find.Execute 
    MsgBox hds & ":" & Selection.Information(wdActiveEndPageNumber), vbOKOnly 
Next 

Dodanie nowej pytanie:

Podczas ustawiania wartości strFooter, używasz ReDim do rozmiaru tablicy, gdy należy używać ReDim Preserve:

ReDim Preserve strFootNum(1 To UBound(astrHeadings)) 

ale chyba UBound(astrHeadings) zmienia się podczas pętli w pytaniu For, że to prawdopodobnie najlepsza praktyka wyciągnąć ReDim oświadczenie zewnątrz pętli:

ReDim strFootNum(0 To UBound(astrHeadings)) 
For i = 0 To UBound(astrHeadings) 
    With Selection.Find 
     .Text = Trim(astrHeadings(i)) 
     .Wrap = wdFindContinue 
    End With 

    If Selection.Find.Execute = True Then 
     strFootNum(i) = Selection.Information(wdActiveEndPageNumber) 
    Else 
     strFootNum(i) = 0 'Or whatever you want to do if it's not found' 
    End If 
    Selection.Move 
Next 

Dla porównania, zestawienie ReDim ustawia wszystkie elementy w tablicy z powrotem do 0, natomiast ReDim Preserve zachowuje wszystkie dane w tablicy przed jej rozmiaru.

Zwróć także uwagę na linie Selection.Move i .Wrap = wdFindContinue - Myślę, że to one stanowiły przyczynę problemu z moimi wcześniejszymi sugestiami. Wybór zostałby ustawiony na końcową stronę, ponieważ wyszukiwanie nie było owijania w żadnym innym przypadku niż pierwsze uruchomienie.