A
alwynb
Guest
Hi there,
I would like to create an app to make a list of all files of a folder and its subfolders (sizes, dates etc) and store it in a table. I have got something off the web for Excel below but I want more than the 65000 row limit.
Unfortunately I do not have sufficient experience to convert the VBA for Excel below to be running oin Access. Can anyone give me some pointers?
Regards
Option Explicit
Sub PopulateDirectoryList()
'dimension variables
Dim objFSO As FileSystemObject, objFolder As Folder
Dim objFile As File, strSourceFolder As String, x As Long, i As Long
''Dim wbNew As Workbook, wsNew As Worksheet
ToggleStuff False 'turn of screenupdating
Set objFSO = New FileSystemObject 'set a new object in memory
strSourceFolder = BrowseForFolder 'call up the browse for folder routine
If strSourceFolder = "" Then Exit Sub
''Workbooks.Add 'create a new workbook
''Set wbNew = ActiveWorkbook
''Set wsNew = wbNew.Sheets(1) 'set the worksheet
''wsNew.Activate
'format a header
''With wsNew.Range("A1:F1")
'' .Value = Array("File", "Size", "Modified Date", "Last Accessed", "Created Date", "Full Path", "Size")
'' .Interior.ColorIndex = 7
'' .Font.Bold = True
'' .Font.Size = 12
''End With
With Application.FileSearch
.LookIn = strSourceFolder 'look in the folder browsed to
.FileType = msoFileTypeAllFiles 'get all files
.SearchSubFolders = True 'search sub directories
.Execute 'run the search
For x = 1 To .FoundFiles.Count 'for each file found, by the count (or index)
i = x 'make the variable i = x
If x > 60000 Then 'if there happens to be more than multipls of 60,000 files, then add a new sheet
i = x - 60000 'set i to the right number for row placement below
Set wsNew = wbNew.Sheets.Add(after:=Sheets(wsNew.Index))
With wsNew.Range("A1:F1")
.Value = Array("File", "Parent Folder", "Full Path", "Modified Date", _
"Last Accessed", "Size")
.Interior.ColorIndex = 7
.Font.Bold = True
.Font.Size = 12
End With
End If
On Error GoTo Skip 'in the event of a permissions error
Set objFile = objFSO.GetFile(.FoundFiles(x)) 'set the object to get it's properties
With wsNew.Cells(1, 1) 'populate the next row with the variable data
.Offset(i, 0) = objFile.Name
.Offset(i, 1) = Format(objFile.Size, "0,000") & " KB"
.Offset(i, 2) = objFile.DateLastModified
.Offset(i, 3) = objFile.DateLastAccessed
.Offset(i, 4) = objFile.DateCreated
.Offset(i, 5) = objFile.Path
End With
' Next objFile
Skip:
'this is in case a Permission denied error comes up or an unforeseen error
'Do nothing, just go to next file
Next x
''wsNew.Columns("A:F").AutoFit
End With
'clear the variables
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
Set wsNew = Nothing
Set wbNew = Nothing
ToggleStuff True 'turn events back on
End Sub
Sub ToggleStuff(ByVal x As Boolean)
Application.ScreenUpdating = x
Application.EnableEvents = x
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'''Code from kpuls, www.VBAExpress.com..portion of Knowledge base submission
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
ToggleStuff True
End Function
I would like to create an app to make a list of all files of a folder and its subfolders (sizes, dates etc) and store it in a table. I have got something off the web for Excel below but I want more than the 65000 row limit.
Unfortunately I do not have sufficient experience to convert the VBA for Excel below to be running oin Access. Can anyone give me some pointers?
Regards
Option Explicit
Sub PopulateDirectoryList()
'dimension variables
Dim objFSO As FileSystemObject, objFolder As Folder
Dim objFile As File, strSourceFolder As String, x As Long, i As Long
''Dim wbNew As Workbook, wsNew As Worksheet
ToggleStuff False 'turn of screenupdating
Set objFSO = New FileSystemObject 'set a new object in memory
strSourceFolder = BrowseForFolder 'call up the browse for folder routine
If strSourceFolder = "" Then Exit Sub
''Workbooks.Add 'create a new workbook
''Set wbNew = ActiveWorkbook
''Set wsNew = wbNew.Sheets(1) 'set the worksheet
''wsNew.Activate
'format a header
''With wsNew.Range("A1:F1")
'' .Value = Array("File", "Size", "Modified Date", "Last Accessed", "Created Date", "Full Path", "Size")
'' .Interior.ColorIndex = 7
'' .Font.Bold = True
'' .Font.Size = 12
''End With
With Application.FileSearch
.LookIn = strSourceFolder 'look in the folder browsed to
.FileType = msoFileTypeAllFiles 'get all files
.SearchSubFolders = True 'search sub directories
.Execute 'run the search
For x = 1 To .FoundFiles.Count 'for each file found, by the count (or index)
i = x 'make the variable i = x
If x > 60000 Then 'if there happens to be more than multipls of 60,000 files, then add a new sheet
i = x - 60000 'set i to the right number for row placement below
Set wsNew = wbNew.Sheets.Add(after:=Sheets(wsNew.Index))
With wsNew.Range("A1:F1")
.Value = Array("File", "Parent Folder", "Full Path", "Modified Date", _
"Last Accessed", "Size")
.Interior.ColorIndex = 7
.Font.Bold = True
.Font.Size = 12
End With
End If
On Error GoTo Skip 'in the event of a permissions error
Set objFile = objFSO.GetFile(.FoundFiles(x)) 'set the object to get it's properties
With wsNew.Cells(1, 1) 'populate the next row with the variable data
.Offset(i, 0) = objFile.Name
.Offset(i, 1) = Format(objFile.Size, "0,000") & " KB"
.Offset(i, 2) = objFile.DateLastModified
.Offset(i, 3) = objFile.DateLastAccessed
.Offset(i, 4) = objFile.DateCreated
.Offset(i, 5) = objFile.Path
End With
' Next objFile
Skip:
'this is in case a Permission denied error comes up or an unforeseen error
'Do nothing, just go to next file
Next x
''wsNew.Columns("A:F").AutoFit
End With
'clear the variables
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
Set wsNew = Nothing
Set wbNew = Nothing
ToggleStuff True 'turn events back on
End Sub
Sub ToggleStuff(ByVal x As Boolean)
Application.ScreenUpdating = x
Application.EnableEvents = x
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'''Code from kpuls, www.VBAExpress.com..portion of Knowledge base submission
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
ToggleStuff True
End Function
