A search tool to the wishlist

[SteveDB1]

Presently, the windows search tool searches file names, and terms, phrases,
or words within a file.
I just got to try the DSO File search tool, and while I'm impressed, it
takes too long to accomplish what I'm seeking to accomplish.
Recently, a colleague and I found that we have a need to look in
BuiltInDocumentProperties, as mainly he, but both of us have macros that
extract data from the contents of a workbook, and inputs that data into the
various BuiltInDocumentProperty dialogue boxes-- Author, Category, Comments,
etc......
I wanted to obtain a macro that would look in the BuiltInDocumentProperties
for specific search terms we define in an input box. We have multiple files
with large numbers of worksheets that are not identified in the file name. We
do however identify those worksheets in the comments dialogue.
What'd be nice is to have an add-in to the windows search tool that allows
for searching BuiltInDocumentProperty dialogues.

 

[Peter T]

If you've got DSO working, I'm not sure what else you need. FWIW, I added a
custom property named "Sheet Names", and a comma separated list of sheet
names in the Value as text. Following worked fine for me -

Dim dso As DSOFile.OleDocumentProperties
Set dso = New DSOFile.OleDocumentProperties
Dim cp As DSOFile.CustomProperty
dspen sfilename:="c:\my documentents\dsotest.xls"
For Each cp In dso.CustomProperties
If cp.Name = "Sheet Names" Then
arr = Split(dso.CustomProperties(i).Value, ",")
Exit For
End If
Next

"arr" returned my array of sheet names

Obviously you need a way to loop your files and store results. You can use
FSO or simply Dir (some say Dir is not reliable but I've never had a problem
it).

For ideas, following returns files in a folder to a collection, and just for
curiosity thought I'd see if it's possible to find files with a particular
sheet name without first having stored it in Custom properties. Seems to
work for me, but only lightly tested.

Sub test()
' will overwrite columns A:B of the active workbook
Dim sFolder As String, sName As String
Dim col As Collection
Dim i As Long

sFolder = "c:\my documents\"
' default folder for testing
sFolder = Application.DefaultFilePath & "\"

' the sheet name to find
sName = "Sheet name to find" ' case sensitive

Set col = New Collection
If FilesToCol(sFolder, col) = 0 Then
MsgBox "No *.xls in " & sFolder
Exit Sub
End If

ReDim va(1 To col.Count, 1 To 2)

On Error GoTo errH

' press Esc to abort
Application.EnableCancelKey = xlErrorHandler

For i = 1 To col.Count
va(i, 1) = col(i)
Application.StatusBar = i & " / " & UBound(va) & " " & va(i, 1)
va(i, 2) = hasSheet(sFolder & col(i), sName)
Next

Range("a1").Resize(UBound(va), 2).Value = va

done:
'reset application settings
Application.EnableCancelKey = xlInterrupt
Application.StatusBar = False
Exit Sub

errH:
If Err.Number = 18 Then
If MsgBox("Processing file " & i & " / " & UBound(va), vbOKCancel) =
vbOK Then Resume
Else
MsgBox "Error" & vbCr & Err.Description
End If
Resume done
End Sub

Function FilesToCol(sPath As String, c As Collection) As Long
Dim sFile As String

Call Dir("nul")
sFile = Dir(sPath & "*.xls")
Do While Len(sFile)
c.Add sFile
sFile = Dir()
Loop
FilesToCol = c.Count

End Function

Function hasSheet(sFile As String, shtName As String) As Variant
Dim FF As Integer
Dim i As Long, j As Long
Dim cnt As Long
Dim ba() As Byte
Dim by() As Byte
Dim s$

ba() = shtName
FF = FreeFile

On Error GoTo errH

Open sFile For Binary As FF
ReDim by(LOF(FF) - 1)
Get FF, , by() ' read the file into a byte array
Close FF

On Error GoTo 0

For i = 0 To UBound(by)

If by(i) = ba(0) Then
' byte(i) matches the first char of our string
' so lets check the rest
For j = 0 To UBound(ba) Step 2
If by(i + j \ 2) <> ba(j) Then
Exit For ' not enough chars match,
End If
Next
If j = UBound(ba) + 1 Then

' Got to the end of the inner loop so shtName exists in the file
' Look at the next byte, in light testing a 133 or 140
' seems to follow a real sheet name, but look at any debug
' entries (case else) for other possibilities
Select Case by(i + (UBound(ba) + 1) / 2)
Case 133, 140
hasSheet = True
Case Else
' maybe this file should have been included ???
Debug.Print by(i + (UBound(ba) + 1) / 2), shtName, sFile
End Select

If hasSheet Then Exit Function

End If

End If

Next

Exit Function
errH:

Close FF
MsgBox "error reading " & sFile
End Function

Regards,
Peter T

 

[Peter T]

A typo (typical - changing cope after pasting !)

If cp.Name = "Sheet Names" Then
arr = Split(dso.CustomProperties(i).Value, ",")
Exit For
End If
Next

For Each cp In dso.CustomProperties
If cp.Name = "Sheet Names" Then
arr = Split(cp.Value, ",")
Exit For
End If
Next

Peter T