'//////////////////////////////////////////////////////////////////////////////////////////////
'/////////////Main - This macro will display the values of custom properties///////////////////
'//////////////////for all .doc files in the selected folder and subfolders////////////////////
'//////////////////////////////////////////////////////////////////////////////////////////////
Option Explicit
'Global Declarations
Public FSO As Object 'a FileSystemObject
Public oFolder As Object 'the folder object
Public oSubFolder As Object 'the subfolders collection
Public oFiles As Object 'the files object
Dim WkSht As Worksheet, i As Long, j As Long
Sub Main()
    'Note: this code requires a reference to the Word object model (Microsoft Word 12.0 Object Library)
    'Minimize screen flickering
    Application.ScreenUpdating = False
    'Declare local variables
    Dim wdApp As New word.Application
    Dim strFolder As String, strFile As String
    Dim word
    Set word = CreateObject("Word.Application")
    word.Visible = False
    'Prompt user to browse for the starting folder
    strFolder = GetTopFolder
    'Exit macro if user cancels
    If strFolder = "" Then Exit Sub
    Set WkSht = ActiveSheet
    i = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
    j = 1
    'Search the top level folder
    Call GetFolder(strFolder & "\")
    'Search the subfolders for more files
    Call SearchSubFolders(strFolder)
    'Return control of the status bar to Word
    Application.StatusBar = ""
    'Restore screen updating
    Application.ScreenUpdating = True
    word.Quit
    MsgBox "Data from " & i - j & " files extracted.", vbOKOnly
'////////////////////////////////////////END///////////////////////////////////////////////////
End Sub
'//////////////////////////////////////////////////////////////////////////////////////////////
'/////GetTopFolder - This function prompts the user to select a folder for processing//////////
'//////////////////////////////////////////////////////////////////////////////////////////////
Function GetTopFolder() As String
    GetTopFolder = ""
    Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
    If (Not oFolder Is Nothing) Then GetTopFolder = oFolder.Items.Item.Path
    Set oFolder = Nothing
'////////////////////////////////////////END///////////////////////////////////////////////////
End Function
'//////////////////////////////////////////////////////////////////////////////////////////////
'////////SearchSubFolders - This sub searches for subfolders in the starting path//////////////
'//////////////////////////////////////////////////////////////////////////////////////////////
Sub SearchSubFolders(strStartPath As String)
    If FSO Is Nothing Then
        Set FSO = CreateObject("scripting.filesystemobject")
    End If
    Set oFolder = FSO.GetFolder(strStartPath)
    Set oSubFolder = oFolder.subfolders
    For Each oFolder In oSubFolder
        Set oFiles = oFolder.Files
        'Search the current folder
        Call GetFolder(oFolder.Path & "\")
        'Call ourself to see if there are subfolders below
        SearchSubFolders oFolder.Path
    Next
'////////////////////////////////////////END///////////////////////////////////////////////////
End Sub
'//////////////////////////////////////////////////////////////////////////////////////////////
'/////////////GetFolder - This sub prompts the user to select a folder for processing//////////
'//////////////////////////////////////////////////////////////////////////////////////////////
Sub GetFolder(strFolder As String)
    Dim strFile As String
    strFile = Dir(strFolder & "*.doc")
    'Process the files in the folder
    While strFile <> ""
        i = i + 1
        'Update the status bar is just to let us know where we are
        Application.StatusBar = strFolder & strFile
        Call UpdateFileData(strFolder & strFile)
        strFile = Dir()
    Wend
'////////////////////////////////////////END///////////////////////////////////////////////////
End Sub
'//////////////////////////////////////////////////////////////////////////////////////////////
'////////UpdateFileData - This sub updates the spreadsheet with most recent file data//////////
'//////////////////////////////////////////////////////////////////////////////////////////////
Sub UpdateFileData(strDoc As String)
    Dim wdDoc As word.Document
    Dim wdDocProp As Object
    'Open the document
    WkSht.Cells(i, 1).Value = strDoc
    Set wdDoc = Documents.Open(strDoc, AddToRecentFiles:=False, ReadOnly:=False, Format:=wdOpenFormatAuto, Visible:=False)
    With wdDoc
        'Sort through each custom property
        For Each wdDocProp In .CustomDocumentProperties
            With wdDocProp
                Select Case .Name
                    'Dump values of checkboxes into current row
                    Case "AssMan": WkSht.Cells(i, 2).Value = .Value
                    Case "Dam": WkSht.Cells(i, 3).Value = .Value
                    Case "Env": WkSht.Cells(i, 4).Value = .Value
                    Case "Fuel": WkSht.Cells(i, 5).Value = .Value
                    Case "Health": WkSht.Cells(i, 6).Value = .Value
                    Case "Human": WkSht.Cells(i, 7).Value = .Value
                    Case "Maint": WkSht.Cells(i, 8).Value = .Value
                    Case "Prod": WkSht.Cells(i, 9).Value = .Value
                    Case "ProMan": WkSht.Cells(i, 10).Value = .Value
                    Case "WorkMan": WkSht.Cells(i, 11).Value = .Value
                    Case "Other": WkSht.Cells(i, 12).Value = .Value
                End Select
            End With
        Next
        .Close SaveChanges:=False
    End With
    'Let Word do its housekeeping
    DoEvents
    Set wdDoc = Nothing
'////////////////////////////////////////END///////////////////////////////////////////////////
End Sub