I was asked to search a group of PC's C:\Local for a specific file type.  I have the below script which does everything I want but will only search the C:\Local folder and not subfolders.  I have tried modifying it but as soon as I do I encounter errors.

Could someone please advise what code I am missing?

Cheers
 
****************************************************************************
on error resume next

Const ForReading = 1
Const ForWriting = 2

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile ("c:\TagNumbers.txt", ForReading)
Wscript.echo objtextfile
' *************************************************************
' create the input array
strText = objTextFile.ReadAll
objTextFile.Close
arrComputers = Split(strText,vbcrlf)
' *************************************************************

Dim objFolder, objFile, TS
Dim strDirectory, strWildCard, strPattern
Dim strLog, blnFound, i
Dim objRegExpr

    'Create an instance of the regexp object
    Set objRegExpr = CreateObject("VBScript.RegExp")
    
    strWildCard = "*.pet"
    
    'Update the wildcard string to define a valid regular expression
    strPattern = Replace(strWildCard, ".", "\.")
    strPattern = Replace(strPattern, "*", ".*")
    strPattern = "^" & strPattern & "$"
    strPattern = Replace(strPattern, ".*$", ".+$")

    objRegExpr.Pattern = strPattern
    objRegExpr.Global = True
    objRegExpr.IgnoreCase = True

    'Set where you will log your findings
    strLog = "c:\mylog.txt"
    Set TS = objFSO.OpenTextFile(strLog,ForWriting,true)
    

For i = 0 To UBound(arrComputers)
    'Get the directory you are searching
    strDirectory = "\\" & arrComputers(i) & "\c$\windows\"
    
    'Set your found flag
    blnFound = False
    
    'Check that that the directory exists. This shouldn't take  
    'long to retrun false if the machine can't be reached.
    If objFSO.FolderExists(strDirectory) Then
        'Get the current folder
        Set objFolder = objFSO.GetFolder(strDirectory)
        
        'Loop through all the files in the folder
        For Each objFile In objFolder.Files
            'Check if the file matches the wildcard search
            If objRegExpr.Test(objFile.Name) Then
                'Add file to log if found
                TS.WriteLine(arrComputers(i) & vbTab & objPath.Name)
                blnFound = True
            End If
        Next
    Else
        'Note in the log if the machine couldn't be reached
        TS.WriteLine(arrComputers(i) & " cannot be reached")
        blnFound = True
    End If
    
    'Add note if the file wasn't found
    If not blnFound Then
        TS.WriteLine(arrComputers(i) & vbTab & strWildCard & " not found")
    End if
    
    'Add an extra line to seperate the machines
    TS.WriteLine("")


Next

TS.Close
Set TS = Nothing
Set objRegExpr = Nothing
    
MsgBox "Done"
0 Comments   [ + ] Show Comments

Comments

  • This content is currently hidden from public view.
    Reason: Removed by member request
    For more information, visit our FAQ's.
Please log in to comment

Answers

2
Put the search code in a Sub/Function and call it recursively.

Here's some code I found in an old project. It was designed to move file types from one folder to another. I'm sure you can work out how to adapt it to suit your requirement:
'// Creates a dictionary containing details of files in and under a directory.
'// Drop a folder on this script or browse for it.
Option Explicit

Dim blnResult
Dim intIndex
Dim strMsg
Dim objFSO
Dim objWSHShell
Dim strScriptFullName
Dim objDictionary
Dim strOut
Const strNameSeparator = "|"

Const strBrowseForFolderTitle = "Select a folder to process"

strScriptFullName = WScript.ScriptFullName

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objWSHShell = CreateObject("Shell.Application")
Set objDictionary = CreateObject("Scripting.Dictionary")

Call Main

Set objDictionary = Nothing
Set objWSHShell = Nothing
Set objFSO = Nothing

Sub Main
Dim objFolder
Dim strFolder
Dim strDest

'// Delete existing CSV report
If objFSO.FileExists(FileNameLikeMine("csv")) Then objFSO.DeleteFile FileNameLikeMine("csv")

'// Get the folder you want info on
If WScript.Arguments.Count = 1 Then
strFolder = WScript.Arguments(0)
Else
strFolder = BrowseForFolder(strBrowseForFolderTitle)
End If

If strFolder = "" Then
Exit Sub
End If

'// Write the header (element number & names of the elements) to the CSV report/dictionary
' Call WriteHeader

Call HandleExtension(".MFS", strFolder, "C:\IMS Health\DVW\DWNLOAD")
Call HandleExtension(".XLS", strFolder, "C:\IMS Health\DVW\REPORTS")
Call HandleExtension(".DVR", strFolder, "C:\IMS Health\Dataview\DATA")

End Sub

Sub HandleExtension(ByVal strExt, ByVal strSourceFolder, ByVal strDestinationFolder)
Dim arrDictItems
Dim arrDictKeys
Dim strKey
Dim strItem

'// Don't even bother to start if the destination folder doesn't exist
If Not objFSO.FolderExists(strDestinationFolder) Then
strMsg = "The destination folder '" & strDestinationFolder & "' does not exist."
MsgBox strMsg, vbOKOnly + vbExclamation
Exit Sub
End If

'// Because I decided to call the extension types one by one,
'// thus using only one key, rather than x number
'// (where 'x' is the number of extensions to be processed)
'// we need to empty the dictionary
On Error Resume Next
objDictionary.RemoveAll
On Error Goto 0

strOut = ""
Call RecurseExtensions(objFSO.GetFolder(strSourceFolder), strExt)
'Call RecurseFiles(objFSO.GetFolder(strSourceFolder))

If IsEmpty(objDictionary) Then
Exit Sub
End If

'// Now that we have a dictionary, we can process the items in it
With objDictionary
arrDictKeys = .Keys
arrDictItems = .Items

For intIndex = 0 To .Count - 1
strKey = arrDictKeys(intIndex)
strItem = .Item(arrDictKeys(intIndex))

'WScript.Echo "Key = " & strKey & " Item = " & strItem
'// The data looks like this:
'// Path_to_file, Name_of_file, Size, File type
'// separator (see strNameSeparator)
'// Path_to_file, Name_of_file, Size, File type
'// etc

'// This next call is what makes this script reasonably generic:
'// just pass the data to a function which does what you want it to do

blnResult = StartProcessing(strItem, strDestinationFolder)
Next
End With
End Sub

Sub RecurseExtensions(ByVal objFolderName, ByVal strExt)
Dim objSubFolders
Dim objSubFolder
Dim objFolder
Dim objFile
Dim strDetails
Dim intElement
Dim strFolderName
Dim strExtension

strFolderName = objFolderName.Path
Set objFolder = objWSHShell.Namespace(strFolderName)
If Err.Number <> 0 Then
Exit Sub
End If

'// Write the actual data elements for each file
For Each objFile in objFolder.Items
With objDictionary
If InStr(objFile.Name, ".") Then
strExtension = UCase(Mid(objFile.Name, InStrRev(objFile.Name, "." ) ) )
If UCase(strExt) = UCase(strExtension) Then
Call Say("Processing " & objFolder.GetDetailsOf(objFile, 0))
If strOut <> "" Then
strOut = strOut & strNameSeparator
End If

strOut = strOut & strFolderName

'// We're not interested in the rest of this junk
'For intElement = 0 to 37
For intElement = 0 To 2
If strOut <> "" Then
strOut = strOut & ","
End If
strOut = strOut & Replace(objFolder.GetDetailsOf(objFile, intElement), ",", "")
Next

If Not .Exists(strExtension) Then
.Add strExtension, strOut
Else
.Item(strExtension) = strOut
End If
End If
End If
End With
Next

'// Check for any sub-folders and recursively process them
Set objSubFolders = objFolderName.SubFolders
For Each objSubFolder In objSubFolders
If LCase(objSubFolder.Name) <> "recycled" Then
Call RecurseExtensions(objSubFolder, strExt)
End If
Next

Set objFile = Nothing
Set objFolder = Nothing
End Sub

Function StartProcessing(ByVal strData, ByVal strDestination)
Dim arrData
Dim strItem
Dim strPath
Dim strName
Dim strSize
Dim strType
Dim objFile
Dim strSourceFile
Dim strDestinationFile

arrData = Split(strData, strNameSeparator)

For intIndex = 0 To UBound(arrData)
strItem = arrData(intIndex)
WScript.Echo strItem

'// Split the data into an array
strPath = Split(strItem, ",")(0)
strName = Split(strItem, ",")(1)
strSize = Split(strItem, ",")(2)
strType = Split(strItem, ",")(3)

strSourceFile = strPath & "\" & strName
strDestinationFile = strDestination & "\" & strName

With objFSO
Set objFile = .GetFile(strSourceFile)
objFile.Copy(strDestinationFile)

If Not .FileExists(strDestinationFile) Then
strMsg = "Failed to copy '" & strSourceFile & "' to '" & strDestinationFile
MsgBox strMsg, vbOKOnly + vbExclamation
End If
Set objFile = Nothing
End With
Next

End Function

Sub RecurseFiles(ByVal objFolderName)
Dim objSubFolders
Dim objSubFolder
Dim objFolder
Dim objFile
Dim strOut
Dim intElement
Dim strFolderName

strFolderName = objFolderName.Path
Set objFolder = objWSHShell.Namespace(strFolderName)
If Err.Number <> 0 Then
Exit Sub
End If

'// Write the actual data elements for each file
For Each objFile in objFolder.Items
Call Say("Processing " & objFolder.GetDetailsOf(objFile, 0))
If strOut <> "" Then
strOut = strOut & vbCrLf
End If

strOut = strOut & strFolderName

'// We're not interested in the rest of this junk
'For intElement = 0 to 37
For intElement = 0 To 2
If strOut <> "" Then
strOut = strOut & ","
End If
strOut = strOut & Replace(objFolder.GetDetailsOf(objFile, intElement), ",", "")
Next

Call AddLineToDictionary(strOut)
strOut = ""
Next

'// Check for any sub-folders and recursively process them
Set objSubFolders = objFolderName.SubFolders
For each objSubFolder in objSubFolders
If LCase(objSubFolder.Name) <> "recycled" Then
Call RecurseFiles(objSubFolder)
End If
Next
End Sub

Function BrowseForFolder(strPrompt)
'// Uses the "Shell.Application" (only present in Win98 and newer)
'// to bring up a file/folder selection window. Falls back to an
'// ugly input box under Win95.

'Shell32.Shell SpecialFolder constants
Const ssfPERSONAL = 5 '// My Documents
Const ssfDRIVES = 17 '// My Computer
Const ssfWINDOWS = 36 '// Windows
Const SFVVO_SHOWALLOBJECTS = 1
Const SFVVO_SHOWEXTENSIONS = 2

Const BIF_RETURNONLYFSDIRS = &H0001
Const BIF_EDITBOX = &H0010
Const BIF_VALIDATE = &H0020
Const BIF_NEWDIALOGSTYLE = &H0040

Dim objFolder
Dim lngView
Dim strPath

If Instr(TypeName(objWSHShell), "Shell") = 0 Then
BrowseForFolder = InputBox(strPrompt, "Select Folder", CreateObject("Scripting.FileSystemObject").GetParentFolderName(strScriptFullName))
Exit Function
End If

lngView = SFVVO_SHOWALLOBJECTS Or SFVVO_SHOWEXTENSIONS
lngView = lngView + BIF_NEWDIALOGSTYLE + BIF_VALIDATE + BIF_EDITBOX + BIF_RETURNONLYFSDIRS

strPath = ""

Set objFolder = objWSHShell.BrowseForFolder(&0, strPrompt, lngView, ssfDRIVES)
Err.Clear

On Error Resume Next
strPath = objFolder.ParentFolder.ParseName(objFolder.Title).Path

'// An error occurs if the user selects a drive instead of a folder
'// so handle it here
Select Case Err.Number
Case 0
BrowseForFolder = strPath
Case 424
'// User probably selected a drive. Let's see.
'// First, have a fall-back option
BrowseForFolder = objFolder.Title

strPath = objFolder.Title
If Len(strPath) > 0 Then
intIndex = InStr(strPath, ":")
If intIndex > 0 Then
strPath = Mid(strPath, intIndex - 1, 2) & "\"
End If
End If
Case Else
End Select

'// If the user *types (or pastes) in* an incorrect path, no error is raised
'// so handle it here
If Len(strPath) > 0 Then
'// Only process if something was entered/selected
If objFSO.FolderExists(strPath) Then
BrowseForFolder = strPath
Exit Function
End If

strMsg = "The folder '" & strPath & "' does not exist."
MsgBox strMsg, vbOKOnly + vbExclamation
BrowseForFolder = ""
End If
On Error Goto 0
End Function

Sub Say(strMessage)
If LCase(Right(WScript.FullName, 12)) = "\cscript.exe" Then
WScript.Echo strMessage
End If
End Sub

Sub AddLineToDictionary(ByVal strText)
'// This routine was designed around AddLineToCSVFile so the string comes in as a CSV line.
Dim strPath
Dim strName
Dim strType
Dim strSize

strPath = Split(strText, ",")(0)
strName = Split(strText, ",")(1)
strSize = Split(strText, ",")(2)
strType = Split(strText, ",")(3)

'// Include the path to make the key unique. Without it, subsequent keys wouldn't get added
'// because the key would already exist. I leave the path in the item because I can use
'// Split to get at it, rather than string manipulation of the key
objDictionary.Add strPath & "\" & strName, strSize & strNameSeparator & strType & strNameSeparator & strPath

End Sub

Sub AddLineToCSVFile(ByVal strText)
Dim objTextFile
Const intForAppending = 8
Set objTextFile = objFSO.OpenTextFile(Left(strScriptFullName, InstrRev(strScriptFullName, ".")) & "csv", intForAppending, True)

With objTextFile
.WriteLine strText
.Close
End With
End Sub

Function FileNameLikeMine(ByVal strFileExtension)
'// Returns a file name the same as the script name
'// except for the file extension.
Dim strExtension

strExtension = strFileExtension
If Len(strExtension) < 1 Then
strExtension = "txt"
End If

If strExtension = "." Then
strExtension = "txt"
End If

If Left(strExtension,1) = "." Then
strExtension = Mid(strExtension, 2)
End If

FileNameLikeMine = Left(strScriptFullName, InstrRev(strScriptFullName, ".")) & strExtension
End Function

Sub WriteHeader
strOut = "Path"
'// We're not interested in the rest of this junk
'For intElement = 0 To 37
For intElement = 0 To 2
If strOut <> "" Then
strOut = strOut & ","
End If

With objFolder
strOut = strOut & .GetDetailsOf(.Items, intElement)
End With
Next
End Sub

SearchFolders(strStartIn, strSearchItem)
Answered 11/21/2014 by: VBScab
Red Belt

  • Thanks, VBScab.
    As per usual the requirements have changed but will have a look through your code. Much appreciated.
Please log in to comment
Answer this question or Comment on this question for clarity