Get list of titles from within files

Neat trick to a relatively simple inquiry.

---

-----Original Message-----
From: Word-Pc List [mailto:WORD-PC@liverpool.ac.uk] On Behalf Of Karen Murri
Sent: Tuesday, February 19, 2019 6:20 AM
To: WORD-PC@liverpool.ac.uk
Subject: Get list of titles from within files

Hi all,

Hoping for a quick answer before I set someone to working on a putzy task. Windows 10, Word 2016

I have a pile of Word files that should all have a title in them (style = Title). I was hoping to set Windows Explorer to show said title so that I can pull the actual title, along with the file name, into a list. Unfortunately, the title is not appearing in the file properties.

Any ideas on how to quickly accomplish what I need - get a list of file names and their titles?

Thanks,
Karen

---

Sub ListFilesAndTitles()
'
' ListFilesAndTitles Macro
' The best solution is to create a temporary file and copy the data to the file. The modified macro below does that.
' Regarding sorting the results, it could be done in the macro by sorting the arrays but it would be simpler to sort the paragraphs in the temporary file.
' From: Word-Pc List [mailto:WORD-PC@liverpool.ac.uk] On Behalf Of Ken <kae0088@gmail.com>
' Sent: Wednesday, February 20, 2019 6:45 AM
' To: WORD-PC@liverpool.ac.uk
' Subject: Re: Get list of titles from within files
' Sub ListFilesAndTitles()
Dim aRange As Range
Dim fl As String
Dim flNames() As String
Dim fTitle() As String
Dim flCount As Long
Dim j As Long
Dim s As String
Dim mydir As String
Dim nextDoc As Document

  mydir = InputBox("Directory")
  If Right(mydir, 1) <> "\" Then mydir = mydir & "\"
  flCount = 0
  ReDim flNames(0)
  ReDim fTitle(0)
  fl = Dir(mydir & "*.doc*")
  Do While fl <> ""
      Set nextDoc = Documents.Open(FileName:=mydir & fl, Visible:=False)
      Set aRange = Documents(fl).Range
      With aRange.Find
        .ClearFormatting
        .Style = "Title"
        If .Execute Then
          flCount = flCount + 1
          ReDim Preserve flNames(flCount)
          flNames(flCount) = fl
          ReDim Preserve fTitle(flCount)
          fTitle(flCount) = aRange.Text
        End If
      End With
      nextDoc.Close SaveChanges:=wdDoNotSaveChanges
    fl = Dir()
  Loop
  If flCount = 0 Then
    MsgBox "No files found that have a title style "
    Exit Sub
  End If
 
  Documents.Add
 
  For j = 1 To flCount
    Selection.TypeText flNames(j) & "    " & fTitle(j)
  Next j
 
End Sub

---