View Single Post
  #6   Report Post  
Posted to microsoft.public.excel.programming
Jim Cone Jim Cone is offline
external usenet poster
 
Posts: 3,290
Default Alternative to FileSearch for Finding Directories

One more way...
--
Jim Cone
San Francisco, USA
http://www.realezsites.com/bus/primitivesoftware

Sub CallFolderFunction()
Dim strFolder As String
'Specify the partial folder name - note use of "*"
strFolder = "*123456*"
'Specify the top folder in the call...
Call IsFolderThere("C:\Documents and Settings\user\My Documents", strFolder)
End Sub
'---
Private Function IsFolderThere(ByRef strPath As String, ByRef strFolder As String)
'Jim Cone - San Francisco, USA - July 2006
'Requires project reference to "Microsoft Scripting Runtime" library
'Determines whether a folder exists if only a partial folder name is known.
On Error GoTo ScriptErr
Dim objFSO As Scripting.FileSystemObject
Dim objSubFolder As Scripting.Folder
Dim objFolder As Scripting.Folder
Dim strMsg As String

Application.StatusBar = "FINDING FOLDER"
'Bring it to life...
Set objFSO = New Scripting.FileSystemObject

'Check for top folder
On Error Resume Next
Set objFolder = objFSO.GetFolder(strPath)
If Err.Number < 0 Then
MsgBox "No Top Folder:"
GoTo FinishUp
End If
On Error GoTo ScriptErr

For Each objSubFolder In objFolder.SubFolders
'Verify secondary folder exists...
If objSubFolder.Name Like strFolder Then
strMsg = objSubFolder.Path
MsgBox "Folder found__ " & strMsg & " "
GoTo FinishUp
End If
'Call recursive function
DoTheSubFolders objSubFolder, strFolder, strMsg
If Len(strMsg) Then Exit For
Next 'objsubfolder

If Len(strMsg) = 0 Then MsgBox "Folder Not Found "

FinishUp:
On Error Resume Next
Application.StatusBar = False
Set objFSO = Nothing
Set objFolder = Nothing
Set objSubFolder = Nothing
Exit Function

ScriptErr:
MsgBox "Error " & Err.Number & " " & Err.Description
GoTo FinishUp
End Function
'---
'Recursive function
Function DoTheSubFolders(ByRef objFolders As Scripting.Folder, _
ByRef strTitle As String, ByRef strM As String)
Dim scrFolder As Scripting.Folder

For Each scrFolder In objFolders.SubFolders
If scrFolder.Name Like strTitle Then
strM = scrFolder.Path
MsgBox "Folder found__ " & strM & " "
Set scrFolder = Nothing
Exit Function
End If
'If there are more sub folders then go back and run function again.
If scrFolder.SubFolders.Count 0 Then
DoTheSubFolders scrFolder, strTitle, strM
End If
Next 'scrFolder
Set scrFolder = Nothing
End Function
'------------------------------------

wrote in message oups.com...
I was extremely excited when I found FileSearch - it seemed like the
solution to an issue I hadn't manage to get round. Until I found out
the Filesearch isn't actually reliable and this was an issue on my
machine. So now I'm looking for an alternative.

I have a collection of directories which are named by a 12 digit part
number and a part name. I also have an excel sheet with the list of
part numbers in. I want to test to see if all the directories exist .
.. .without using filesearch.

Does anyone have any brilliant ideas?

Thanks