Option Explicit
Public Function fGetFiles(ByVal strSpec As String, ByVal strPath As String) As String()
Dim strFile() As String, strTemp As String
Dim lngCount As Long, lngNum As Long
Const Chunk = 200
On Error GoTo errGetFiles
lngNum = Chunk
ReDim strFile(1 To lngNum)
If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"
lngCount = 1
strTemp = Dir(strPath & strSpec)
Do While Len(strTemp) > 0
If lngCount > UBound(strFile) Then
lngNum = lngNum + Chunk
ReDim Preserve strFile(1 To lngNum)
End If
strFile(lngCount) = strTemp
strTemp = Dir
lngCount = lngCount + 1
Loop
If lngCount > 1 Then
ReDim Preserve strFile(1 To lngCount - 1)
Else
ReDim strFile(-1 To -1) 'Avoid errors when no files. Send back a one element blank array.
End If
fGetFiles = strFile
Exit Function
errGetFiles:
MsgBox Err.Description, vbCritical, "fGetFiles"
End Function
Private Function CountWorksheets(Filename As String) As Integer
Dim xlApp As Object
Dim xlWrk As Object
Set xlApp = CreateObject("EXCEL.APPLICATION")
Set xlWrk = xlApp.Workbooks.Open(Filename)
CountWorksheets = xlApp.ActiveWorkbook.Worksheets.Count
xlWrk.Close
xlApp.Quit
Set xlWrk = Nothing
Set xlApp = Nothing
End Function
Private Sub CommandButton1_Click()
Dim strFiles() As String
Dim i As Integer
Dim strPath As String
strPath = txtPath.Text
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
If Len(Dir(strPath)) = 0 Then
MsgBox "Please enter a valid path"
Exit Sub
End If
strFiles = fGetFiles("*.xls", strPath)
For i = 1 To UBound(strFiles)
ActiveSheet.Cells(i, 1).Value = strFiles(i)
ActiveSheet.Cells(i, 2).Value = CountWorksheets(strPath & strFiles(i))
Next
End Sub
|
