वर्ड दस्तावेज़ से शीर्षलेख प्राप्त करना

Question

वीबीए का उपयोग करके किसी शब्द दस्तावेज़ में सभी शीर्षकों की सूची कैसे प्राप्त करें?

Answer 1

आप इस समारोह की तरह मतलब (जो वास्तव में एक नया शब्द दस्तावेज़ में एक स्रोत शब्द दस्तावेज़ से सभी शीर्षकों कॉपी करें):

(मैं astrHeadings का मानना ​​है = _docSource.GetCrossReferenceItems(wdRefTypeHeading) समारोह इस कार्यक्रम में महत्वपूर्ण है, और अनुमति चाहिए आप 6 मार्च को पुनः प्राप्त करने के लिए आप क्या कह रहे हैं) @kol द्वारा

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 and footer. 
    Set rng = docOutline.Content 
    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 

अद्यतन, 2018

हालांकि astrHeadings एक सरणी है (IsArray रिटर्न True, और TypeNameString() देता है) मुझे type mismatch त्रुटि मिलती है जब मैं वीबीस्क्रिप्ट में अपने तत्वों तक पहुंचने का प्रयास करता हूं (विंडोज 10 प्रो 170 9 1629 9.248 पर v5.8.16384)। यह एक वीबीस्क्रिप्ट-विशिष्ट समस्या होनी चाहिए, क्योंकि यदि मैं वर्ड के वीबीए संपादक में एक ही कोड चलाता हूं तो मैं तत्वों तक पहुंच सकता हूं। मैं टीओसी की तर्ज पुनरावृत्ति समाप्त हो गया है, क्योंकि यह VBScript से भी काम करता है: दस्तावेज़ में पैराग्राफ लूप करने के लिए शीर्षकों की सूची प्राप्त करने के लिए

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

Answer 2

सबसे आसान तरीका है, है, उदाहरण के लिए:

Sub ReadPara() 

    Dim DocPara As Paragraph 

    For Each DocPara In ActiveDocument.Paragraphs 

    If Left(DocPara.Range.Style, Len("Heading")) = "Heading" Then 

     Debug.Print DocPara.Range.Text 

    End If 

    Next 


End Sub 

वैसे, मुझे लगता है कि अनुच्छेद सीमा के अंतिम चरित्र को हटाने का एक अच्छा विचार है। अन्यथा, यदि आप किसी संदेश बॉक्स या दस्तावेज़ में स्ट्रिंग भेजते हैं, तो Word एक अतिरिक्त नियंत्रण वर्ण प्रदर्शित करता है। उदाहरण के लिए:

Left(DocPara.Range.Text, len(DocPara.Range.Text)-1) 

Answer 3

आप दस्तावेज़ में सामग्री की एक तालिका भी बना सकते हैं और इसकी प्रतिलिपि बना सकते हैं। यह शीर्षक से पैरा रेफ को अलग करता है, जो कि यदि आपको किसी अन्य संदर्भ में पेश करने की आवश्यकता है तो यह आसान है। यदि आप अपने डॉक्टर में टीओसी नहीं चाहते हैं, तो कॉपी एन पेस्ट के बाद बस इसे हटा दें। जे।

Answer 4

यह मैक्रो मेरे लिए खूबसूरती से काम करता है (वर्ड 2010)। मैंने कार्यक्षमता को थोड़ा बढ़ा दिया है: अब यह उपयोगकर्ता को न्यूनतम स्तर दर्ज करने के लिए संकेत देता है, और उस स्तर के नीचे उपशीर्षक को दबाता है।

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 astrHeadings As Variant 
    Dim strText As String 
    Dim intLevel As Integer 
    Dim intItem As Integer 
    Dim minLevel As Integer 

    Set docSource = ActiveDocument 
    Set docOutline = Documents.Add 

    minLevel = 1 'levels above this value won't be copied. 
    minLevel = CInt(InputBox("This macro will generate a new document that contains only the headers from the existing document. What is the lowest level heading you want?", "2")) 

    ' Content returns only the 
    ' main body of the document, not 
    ' the headers and footer. 
    Set rng = docOutline.Content 
    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))) 

     If intLevel <= minLevel Then 

      ' 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 
     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 

Answer 5

सभी शीर्षकों (LEVEL5 तक) निकालने के लिए सबसे तेज़ तरीका।

Sub EXTRACT_HDNGS() 
Dim WDApp As Word.Application 'WORD APP 
Dim WDDoc As Word.Document  'WORD DOC 

Set WDApp = Word.Application 
Set WDDoc = WDApp.ActiveDocument 

For Head_n = 1 To 5 
Head = ("Heading " & Head_n) 
WDApp.Selection.HomeKey wdStory, wdMove 

    Do 
     With WDApp.selection 
     .MoveStart Unit:=wdLine, Count:=1  
     .Collapse Direction:=wdCollapseEnd 
     End with 
     With WDApp.Selection.Find 
      .ClearFormatting:   .text = "":  
      .MatchWildcards = False: .Forward = True 
      .Style = WDDoc.Styles(Head) 
     If .Execute = False Then GoTo Level_exit 
      .ClearFormatting 
     End With 

     Heading_txt = RemoveSpecialChar(WDApp.Selection.Range.text, 1):    Debug.Print Heading_txt 
     Heading_lvl = WDApp.Selection.Range.ListFormat.ListLevelNumber:    Debug.Print Heading_lvl 
     Heading_lne = WDDoc.Range(0, WDApp.Selection.Range.End).Paragraphs.Count: Debug.Print Heading_lne 
     Heading_pge = WDApp.Selection.Information(wdActiveEndPageNumber):   Debug.Print Heading_pge 

     If Wdapp.Selection.Style = "Heading 1" Then GoTo Level_exit 
     Wdapp.Selection.Collapse Direction:=wdCollapseStart 
    Loop 
Level_exit: 
Next Head_n 

End Sub 

Answer 6

वॉनसी उत्तर पर विकिस टिप्पणी के बाद, यह कोड मेरे लिए काम करता है। यह कार्य तेजी से बनाता है।

Public Sub CopyHeadingsInNewDoc() 
    Dim docOutline As Word.Document 
    Dim docSource As Word.Document 
    Dim rng As Word.Range 

    Dim astrHeadings As Variant 
    Dim strText As String 
    Dim longLevel As Integer 
    Dim longItem As Integer 

    Set docSource = ActiveDocument 
    Set docOutline = Documents.Add 

    ' Content returns only the 
    ' main body of the document, not 
    ' the headers and footer. 
    Set rng = docOutline.Content 
    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 longDiff 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. 
    longDiff = Len(strOriginal) - Len(strTemp) 
    GetLevel = (longDiff/2) + 1 
End Function 

Answer 7

इतनी बार पहिया को फिर से क्यों बदलना?!

ए "सभी शीर्षकों की सूची" दस्तावेज़ का मानक वर्ड इंडेक्स है!

Sub Macro1() 
    ActiveDocument.TablesOfContents.Add Range:=Selection.Range, _ 
     RightAlignPageNumbers:=True, _ 
     UseHeadingStyles:=True, _ 
     UpperHeadingLevel:=1, _ 
     LowerHeadingLevel:=5, _ 
     IncludePageNumbers:=True, _ 
     AddedStyles:="", _ 
     UseHyperlinks:=True, _ 
     HidePageNumbersInWeb:=True, _ 
     UseOutlineLevels:=True 
End Sub