Sub Outline()
Application.ScreenUpdating = False
Dim strInFold As String, strOutFold As String, strFile As String, strOutFile As String
‘Dim TOC As TableOfContents, Para As Paragraph, Tbl As Table, _
‘ Sctn As Section, Rng As Range
Dim DocSrc As Document, DocTOC As Document
'Call the GetFolder Function to determine the folder to process
strInFold = GetFolder
If strInFold = "" Then Exit Sub
strFile = Dir(strInFold & "\*.doc", vbNormal)
'Check for documents in the folder - exit if none found
If strFile <> "" Then strOutFold = strInFold & "\Output"
'Test for an existing outpfolder & create one if it doesn't already exist
If Dir(strOutFold, vbDirectory) = "" Then MkDir strOutFold
strFile = Dir(strInFold & "\*.doc", vbNormal)
'Process all documents in the chosen folder
While strFile <> ""
Set DocSrc = Documents.Open(FileName:=strInFold & "\" & strFile, AddTorecentFiles:=False, Visible:=False)
With DocSrc
 
‘ I HAVE ADDED THIS CODE BELOW WHICH I SENT YOU
 
‘PublicSub CreateOutline()Dim docOutline As Word.Document
Dim docSource As Word.Document
Dim rng As Word.Range
 
Dim astrHeadings AsVariant
Dim strText AsString
Dim intLevel AsInteger
Dim intItem AsInteger
 
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
EndSub
 
PrivateFunction GetLevel(strItem AsString) AsInteger
' 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 AsString
Dim strOriginal AsString
Dim intDiff AsInteger
 
' 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
EndFunction 
 
‘ FOLLOWING IS PART OF YOUR CODE
'String variable for the output filenames
strOutFile = strOutFold & "\" & Split(.Name, ".")(0)
'Copy whatever's left in the source document and paste it into a new text document
.Range.Copy
Set DocTOC = Documents.Add(Visible:=False)
With DocTOC
.Range.Paste
'Save and close the text document
.SaveAs FileName:=strOutFile & "-TOC", AddTorecentFiles:=False
.Close
End With
Set DocTOC = Nothing
 
 
'Close the source document without saving the changes we've made to it
.Close SaveChanges:=False
End With
strFile = Dir()
Wend
Set Rng = Nothing: Set DocSrc = Nothing
Application.ScreenUpdating = True
End Sub
 
Function GetFolder(Optional Title As String, Optional RootFolder As Variant) As String
On Error Resume Next
GetFolder = CreateObject("Shell.Application").BrowseForFolder(0, Title, 0, RootFolder).Items.Item.Path
End Function