Searching with Custom Properties

[jpb103]

Hey fellas,



I've put together a procedure template in word that could potentially be used dozens, hundreds or thousands of times. It has checkboxes so that each procedure can be associated with one or more departments. Each of these checkboxes is linked to a custom property. I need to find a way to search all of these procedures (that will potentially be created) for ones that fall within certain departments (ie: all procedures where the Health and Safety checkbox is checked). I've scoured the internet and come up short for a solution. I've thought about programming up a user form but I can't shake the feeling that there is an easier way to do this. Any thoughts, Word VBA community?

Best Regards,

JP

[macropod]

You could use a macro like the following. It's an Excel macro that will go through all the files in a folder, looking for the "Health and Safety" property. The file's name will be output in column 1 and the property value will be output in column 5. You can add more properties to the Select Case statement and, of course, different Excel columns to output their values to.

The macro has its own folder browser, so all you need do is select the folder to process. Note that the code requires you to set a reference to the Word object model in Excel.

Sub GetWordProcedureData()
     'Note: this code requires a reference to the Word object model
    Application.ScreenUpdating = False
    Dim wdApp As New Word.Application
    Dim wdDoc As Word.Document
    Dim wdDocProp As Object
    Dim strFolder As String, strFile As String
    Dim WkSht As Worksheet, i As Long, j As Long
    strFolder = GetFolder
    If strFolder = "" Then Exit Sub
    Set WkSht = ActiveSheet
    i = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
    Set wdApp = CreateObject("Word.Application")
    strFile = Dir(strFolder & "\*.docx", vbNormal)
    While strFile <> ""
        i = i + 1
        Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, _
          AddToRecentFiles:=False, Visible:=False)
        WkSht.Cells(i, 1).Value = strFile
        With wdDoc
            For Each wdDocProp In .CustomDocumentProperties
                With wdDocProp
                    Select Case .Name
                        Case "Health and Safety": WkSht.Cells(i, 5).Value = .Value
                    End Select
                End With
            Next
        End With
        wdDoc.Close SaveChanges:=False
        strFile = Dir()
    Wend
    wdApp.Quit
    Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
    Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
    Dim oFolder As Object
    GetFolder = ""
    Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
    If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
    Set oFolder = Nothing
End Function

[jpb103]

Hey Paul,

Thanks for the advice. I've set up the reference to the word object model, and the macro runs, but it does not produce any data. When stepping through the code, the while loop is never entered and once wdApp.Quit is reached, excel freezes up and every minute or so displays a message box saying that excel is waiting for another application to complete an OLE action. If I try and exit excel is tells me that it can't do that. Each time I have to open the task manager and kill it to continue.

Thanks again,

JP

*EDIT* I should add that when running the macro without stepping through (F5), it still produces no data but it also does not freeze.

*EDIT 2* OK, I found the problem...I'm a silly goof! The files were .doc and not .docx (This is why the while loop was never being entered). Not real sure why excel was feezing up when I stepped through the code before but I'm not overly worried about it. Issue RESOLVED! Thanks MACROPOD!

[jpb103]

I now realize I need this macro to observe the files in subfolders as well. I've tried making some modifications but alas, she won't run. Any ideas?

[macropod]

You'd need rather different code to loop through sub-folders:

Option Explicit
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
Dim wdApp As New Word.Application
 
Sub Main()
' Minimise screen flickering
Application.ScreenUpdating = False
'Note: this code requires a reference to the Word object model
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String
' Browse for the starting folder
strFolder = GetTopFolder
If strFolder = "" Then Exit Sub
Set wdApp = CreateObject("Word.Application")
Set WkSht = ActiveSheet
i = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
j = i
' Search the top-level folder
Call GetFolder(strFolder & "\")
' Search the subfolders for more files
Call SearchSubFolders(strFolder)
' Return control of status bar to Word
Application.StatusBar = ""
' Restore screen updating
Application.ScreenUpdating = True
MsgBox "Data from " & i - j & " files extracted.", vbOKOnly
End Sub
 
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 Function
 
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 Sub
 
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 Sub
 
Sub UpdateFileData(strDoc As String)
Dim wdDoc As Document, wdDocProp As Object
' Open the document
WkSht.Cells(i, 1).Value = strDoc
Set wdDoc = wdApp.Documents.Open(strDoc, AddToRecentFiles:=False, ReadOnly:=False, Format:=wdOpenFormatAuto, Visible:=False)
With wdDoc
  For Each wdDocProp In .CustomDocumentProperties
    With wdDocProp
      Select Case .Name
        Case "Health and Safety": WkSht.Cells(i, 5).Value = .Value
      End Select
    End With
  Next
  .Close SaveChanges:=False
End With
' Let Word do its housekeeping
DoEvents
Set wdDoc = Nothing
End Sub

[jpb103]

I keep getting a Run-time error '429' (ActiveX component can't create object) on the following line in the UpdateFileData sub:

Set wdDoc = Documents.Open(strDoc, AddToRecentFiles:=False, ReadOnly:=False, Format:=wdOpenFormatAuto, Visible:=False)

*EDIT* I did find a solution, and it appears to work; but I'm not completely happy with it.
From Excel Help:

The class isn't registered. For example, the system registry has no mention of the class, or the class is mentioned, but specifies either a file of the wrong type or a file that can't be found. If possible, try to start the object's application. If the registry information is out of date or wrong, the application should check the registry and correct the information. If starting the application doesn't fix the problem, rerun the application's setup program.

Basically, Word has to be open for the macro to run successfully. Is there a way to open Word initially and then close it (programatically) once the macro is finished?

[jpb103]

Solved. Final code follows:

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

Thanks for all your help, Paul. You truly are the macro master!