search through folder and subfolders

[mp3er3000]

Say my current folder is c:\test\
anyone know how to write vba code that search and execute every files that that directory and its subdirectory. thanks
kevin

 

[SaMaLaKo]

I needed a searchfunction in a program I made.
Did it using this class module:

Option Explicit
'Use this class to find a file in a given directory
'using a custom mask.
'
'The function Search(Path as string, Mask as string) returns a variant array
'containing all the files (with path) that match the mask filter provided.
'The index 0 of the array returned contains how many files were found
'
'The event ChangeDir is raised whenever the function changes to another directory
'
'NOTE: This class uses Windows API functions to find the files,
'not the Visual Basic Dir function, because of the way it must be called.
'Also, the Visual Basic GetAttr function is not used
'because it does not handle some files correctly.
'Instead, I prefer using the GetFileAttribute API.
'
'
Event ChangeDir(Path As String)
Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type
Private Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
  dwFileAttributes As Long
  ftCreationTime As FILETIME
  ftLastAccessTime As FILETIME
  ftLastWriteTime As FILETIME
  nFileSizeHigh As Long
  nFileSizeLow As Long
  dwReserved0 As Long
  dwReserved1 As Long
  cFileName As String * 260
  cAlternate As String * 14
End Type
Private Declare Function FindFirstFile Lib "kernel32.dll" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32.dll" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32.dll" (ByVal hFindFile As Long) As Long
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Files() As Variant

Private Function SystemTimeToDate(system_time As SYSTEMTIME)
    With system_time
        SystemTimeToDate = CDate( _
            Format$(.wMonth) & "/" & _
            Format$(.wDay) & "/" & _
            Format$(.wYear) & " " & _
            Format$(.wHour) & ":" & _
            Format$(.wMinute, "00") & ":" & _
            Format$(.wSecond, "00"))
    End With
End Function

Private Sub FindFiles(Path As String, Mask As String)
  Dim FindInfo As WIN32_FIND_DATA
  Dim TmpFile As String
  Dim Handler As Long, Result As Long
  Dim TimeCreated As SYSTEMTIME, TimeLastModified As SYSTEMTIME

  If Right(Path, 1) <> "\" Then Path = Path + "\"
  Handler = FindFirstFile(Path + Mask, FindInfo) 'Get the first file
  If Handler = -1 Then Exit Sub 'If there is no file, just exit sub
  RaiseEvent ChangeDir(Path)
  DoEvents 'Without this, the event is useless
  Do
    TmpFile = Left(FindInfo.cFileName, InStr(FindInfo.cFileName, vbNullChar) - 1) 'Truncate all the null chars at the end of the string
    Call FileTimeToSystemTime(FindInfo.ftCreationTime, TimeCreated) 'Convert The FileTime To a SystemTime
    Call FileTimeToSystemTime(FindInfo.ftLastWriteTime, TimeLastModified) 'Convert The FileTime To a SystemTime
    If (GetFileAttributes(Path + TmpFile) And vbDirectory) <> vbDirectory Then 'If the filename is not a directory...
        If Files(0) <> "" Then ReDim Preserve Files(UBound(Files) + 1) '...allocate a new item in the array
        Files(UBound(Files)) = TmpFile & ";" & Path & ";" & SystemTimeToDate(TimeCreated) & _
                        ";" & SystemTimeToDate(TimeLastModified) & ";" & FindInfo.nFileSizeLow
    End If
    Result = FindNextFile(Handler, FindInfo) 'Get the next file
  Loop Until Result = 0 'Loop until there are no more files
  FindClose Handler 'We don't want to waste useful memory in this crap, right?
End Sub

Private Sub FindDirectories(Path As String, Mask As String)
  Dim FindInfo As WIN32_FIND_DATA
  Dim TmpFile As String
  Dim Handler As Long, Result As Long

  If Right(Path, 1) <> "\" Then Path = Path + "\"
  FindFiles Path, Mask
  Handler = FindFirstFile(Path + "*.*", FindInfo) 'Get the first subdirectory
  If Handler = -1 Then Exit Sub 'No subdirectories? Damn!!
  RaiseEvent ChangeDir(Path)
  DoEvents 'Without this, the event is useless
  Do
    TmpFile = Left(FindInfo.cFileName, InStr(FindInfo.cFileName, vbNullChar) - 1)  'Truncate all the nulls chars at the end of the string
    If TmpFile <> "." And TmpFile <> ".." Then If (GetFileAttributes(Path + TmpFile) And vbDirectory) = vbDirectory Then FindDirectories Path + TmpFile, Mask 'Let's make sure that it's really a directory. If so, we called again the FindDirectory sub
    Result = FindNextFile(Handler, FindInfo) 'Find files in this subdirectory
  Loop Until Result = 0 'Loop until no more subdirectories are found
  FindClose Handler 'We don't want to waste useful memory in this crap, right?
End Sub

Public Function Search(Path As String, Mask As String) As Variant
  Dim FindInfo As WIN32_FIND_DATA
  Dim TmpFile As String
  Dim Handler As Long, Result As Long

  ReDim Files(0) 'Allocate the files array
  If Right(Path, 1) <> "\" Then Path = Path + "\"
  FindFiles Path, Mask 'Find files in the main directory
  Handler = FindFirstFile(Path + "*.*", FindInfo) 'Are there some other things in the directory?
  If Handler <> -1 Then 'Yeah, It seems so
    Do
      TmpFile = Left(FindInfo.cFileName, InStr(FindInfo.cFileName, vbNullChar) - 1)
      If TmpFile <> "." And TmpFile <> ".." Then If (GetAttr(Path + TmpFile) And vbDirectory) = vbDirectory Then FindDirectories Path + TmpFile, Mask 'If it's not a subdirectory, just ignore it
      Result = FindNextFile(Handler, FindInfo) 'No explanation needed
    Loop Until Result = 0 'Blah blah blah...
  End If
  FindClose Handler
  Search = Files 'If we don't return the array, what do we call the function for?
  Erase Files 'I don't know if the allocated space is deallocated automatically or not, but VB is tricky so we deallocate it manually...we just lose some milliseconds in the process
End Function

Hope this gets you going...

Please tell me if I'm wrong I like to learn from my mistakes...
_____________________________________
Feed a man a fish and feed him for a day.
Teach a man to fish and feed him for a lifetime...

 

[KenWright]

Cribbed this off a file I use for querying all workbooks withina folder - This allows you to pick a folder and will then work with all the Excel files within it. Just put your code in where it says 'DO STUFF':-

Function PickFolder(strStartDir As Variant) As String
    Dim SA As Object, F As Object
    Set SA = CreateObject("Shell.application")
    Set F = SA.BrowseForFolder(0, "Choose a folder", 0, strStartDir)
    If (Not F Is Nothing) Then
        PickFolder = F.items.Item.Path
    End If
    Set F = Nothing
    Set SA = Nothing
End Function

Sub DoStuffToAllFiles()
'This uses the Microsoft Scripting Runtime library, so you need to set a
'reference to that (Tools>References)

    Dim objFSO       As Scripting.FileSystemObject
    Dim objFolder    As Scripting.Folder
    Dim objSubfolder As Scripting.Folder
    Dim objFile      As Scripting.File
    Dim Sh           As Worksheet

    Application.ScreenUpdating = False

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    objfoldpath = PickFolder(strStartDir)
    Set objFolder = objFSO.GetFolder(objfoldpath)
    For Each objFile In objFolder.Files
        If objFile.Type = "Microsoft Excel Worksheet" Then
            Workbooks.Open Filename:=objFolder.Path & "\" & objFile.Name

            With ActiveWorkbook
                For Each Sh In .Worksheets

                    'DO STUFF HERE

                Next Sh
                .Close SaveChanges:=True
            End With

        End If
    Next

    Application.ScreenUpdating = True
End Sub

Regards
Ken...............

----------------------------------------------------------------------------
It's easier to beg forgiveness than ask permission
----------------------------------------------------------------------------