VBA word: Find alle X typografier og indsæt tekst i form

Øeh, programmering ?-)

Vælg Indsæt --> Reference --> Indeks m.m. ... --> Indholdsfortegnelse

-- så kommer det helt automatisk !-)

Som jeg skriver:
Overskrifterne skal hentes ind i en VBA form, i en listboks.

Dvs. at jeg vil lave en form der er tilgængelig uanset hvor jeg står i mit dokument.

Ved at benytte Index funktionen i Word, opretter jeg en indholdsfortegnelse der KUN er tilgængelig et bestemt sted i dokumentet, hvor jeg konstant skal gå tilbage til, for at vælge et nyt sted i mit dokument.

Kan du ikke bruge dokumentoversigt?

I Word 2000 er det menupunktet Vis - Dokumentoversigt.

I dokumentoversigt kan jeg ikke teste, manipulere og sortere overskrifterne. Ved at hente dem ind i en listboks, kan jeg lave mine egne statistikker med mere.

Jeg ønsker blot kode eller forslag der fører til kode, der finder alle forekomster af OverskriftX og indsætter den i en listboks på en Userform.

Det må der være nogen der har et bud på ...

Her er en stump kode at starte med:

    With ActiveDocument.Content.Find
        .ClearFormatting
        .Style = ActiveDocument.Styles("Overskrift 1")
        .Execute
        Do While .Found = True
            MsgBox "Start: " & .Parent.Start & vbCrLf & "Tekst: " & .Parent.Text
            .Execute
        Loop
    End With

Så mangler du bare at lave listboksen.

Tak!
Der er bare lige en lille finurlighed, som jeg ikke lige kan gennemskue, sikkert pga. tidspunktet:-)

Løkken standser ikke ved sidste forekomst - den fortsætter med at vise den sidste forekomst af Overskrift 1. Jobliste/Afslut er eneste udvej.

Det må være Wrap der står forkert, prøv denne:

    With ActiveDocument.Content.Find
        .Forward = True
        .Wrap = wdFindStop
        .ClearFormatting
        .Style = ActiveDocument.Styles("Overskrift 1")
        .Execute
        Do While .Found = True
            MsgBox "Start: " & .Parent.Start & vbCrLf & "Tekst: " & .Parent.Text
            .Execute
        Loop
    End With

Nej! Stadig samme problem.

Men har du i øvrigt et forslag til koden der indlæser overskrifterne i listboksen?

Her er mit umiddelbare forsøg, der ikke rigtig virker som jeg vil ha' det:

(Har selvfølgelig oprettet form og listboks.)

Sætter jeg ikke en begræsning på 5 (IF ...), får jeg fejl!

Sub test1()
Dim indhold(10)
Dim taeller
taeller = 0
    With ActiveDocument.Content.Find
        .Forward = True
        .Wrap = wdFindStop
        .ClearFormatting
        .Style = ActiveDocument.Styles("Overskrift 1")
        .Execute
        Do While .Found = True
            taeller = taeller + 1
            If taeller = 5 Then GoTo videre
            indhold(taeller) = .Parent.Text
            .Execute
        Loop
    End With
videre:
UserForm1.Lst1.Clear

For go = 0 To taeller
    UserForm1.Lst1.AddItem indhold(go)
Next
UserForm1.Show
End Sub

Giver i øvrigt en ekstra blank linier i start og slut.

Hmm - dette virker hos mig, med userform og det hele:

Sub test1()
    Dim indhold(10)
    Dim taeller
    taeller = 0
    With ActiveDocument.Content.Find
        .Forward = True
        .Wrap = wdFindStop
        .ClearFormatting
        .Style = ActiveDocument.Styles("Overskrift 1")
        .Execute
        Do While .Found = True
            taeller = taeller + 1
            indhold(taeller) = .Parent.Text 'Replace(.Parent.Text, vbCr, "")
            'Left(.Parent.Text, Len(.Parent.Text) - 1)
            .Execute
        Loop
    End With
    UserForm1.Lst1.Clear
   
    For go = 1 To taeller
        UserForm1.Lst1.AddItem indhold(go)
    Next
    UserForm1.Show
End Sub


Der kommer ganske vist nogle kedelige afsnitstegn med i listboksen, men det kører uden fejl og løkken slutter når den skal.

Ups, der kom lige nogle ekstra kommentarer med - nogle forsøg på at fjerne afsnitstegnene. Du kan evt. lege med det.

Jeg får fejlen: "Subscript out of range"???

Nåja, det er nok dit array der ikke er stort nok. Prøv uden:

Sub test1()
    UserForm1.Lst1.Clear

    With ActiveDocument.Content.Find
        .Forward = True
        .Wrap = wdFindStop
        .ClearFormatting
        .Style = ActiveDocument.Styles("Overskrift 1")
        .Execute
        Do While .Found = True
            UserForm1.Lst1.AddItem .Parent.Text
            .Execute
        Loop
    End With
   
    UserForm1.Show
End Sub

Jeg forstår det ikke!!!!!

Word låser når jeg kører dit script. Ét eller andet må gå galt. Et eller andet i "do loop".

Prøv en variant:

Sub test2()
    UserForm1.Lst1.Clear

    With ActiveDocument.Content.Find
        .Forward = True
        .Wrap = wdFindStop
        .ClearFormatting
        .Style = ActiveDocument.Styles("Overskrift 1")
        Do While .Execute
            UserForm1.Lst1.AddItem .Parent.Text
        Loop
    End With
   
    UserForm1.Show
End Sub

Arg! Nej, det fungerer heller ikke. Maskinen kører bare derudaf og kun "ctrl+alt+delete", jobliste virker.

Well, I'm lost!
Det kører som sagt fint her.
(Iøvrigt bør du kunne afslutte en løbsk makro med Ctrl-Break)

Prøv at sætte en MsgBox ind før UserForm1.Show for at se om den kommer dertil. Måske er det visningen af formen der går galt?

Så lykkedes det!

Jeg gik væk fra "Activedocument.find" og brugte i stedet "With selection.find". Det gjorde tricket.

Du ledte mig på vej - og tak for dét:-) ........ Hvis du opretter et svar, kan jeg give dig dine velfortjente point!

-------- ENDELIG KODE --------

With Selection.Find
    .ClearFormatting
    .Style = "Overskrift 1"
    Do While .Execute(FindText:="", Forward:=True, _
            Format:=True) = True
        With .Parent
            UserForm1.List1.AddItem Selection.Text
        End With
    Loop
End With
UserForm1.Show

Til lykke med sejren...