Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Adapt this Directory Listing working code to insert a file namepattern prompt.
The following code is a perfectly working Directory Listing.
I adapted it to see all the properties I may need to filter. I do not know if it could be improved but I am happy with it. Now, I would like now to insert separate prompts for the file name pattern like *Cost* and extension type like mdb or accdb for instance. I do not know exactly where I would insert the prompts and process the If tests. Help appreciated, J.P. .. Public X() Public i As Long Public objShell, objFolder, objFolderItem Public FSO, oFolder, Fil Sub MainExtractData() 'Code source : http://www.vbaexpress.com/kb/getarticle.php?kb_id=405 Dim NewSht As Worksheet Dim MainFolderName As String Dim TimeLimit As Long, StartTime As Double ReDim X(1 To 65536, 1 To 7) Set objShell = CreateObject("Shell.Application") TimeLimit = Application.InputBox("Please enter the maximum time that you wish this code to run for in minutes" & vbNewLine & vbNewLine & _ "Leave this at zero for unlimited runtime", "Time Check box", 0) StartTime = Timer Application.ScreenUpdating = False MainFolderName = BrowseForFolder() Set NewSht = ThisWorkbook.Sheets.Add X(1, 1) = "Path" X(1, 2) = "File Name" X(1, 3) = "Size" X(1, 4) = "Type" X(1, 5) = "Modified" X(1, 6) = "Created" X(1, 7) = "Age" ' File Age in Days from Modified Date to Now i = 1 Set FSO = CreateObject("scripting.FileSystemObject") Set oFolder = FSO.GetFolder(MainFolderName) 'Error handling to stop the obscure error that occurs at time when retrieving DateLastAccessed On Error Resume Next For Each Fil In oFolder.Files Set objFolder = objShell.Namespace(oFolder.Path) Set objFolderItem = objFolder.ParseName(Fil.Name) i = i + 1 If i Mod 20 = 0 And TimeLimit < 0 And Timer (TimeLimit * 60 + StartTime) Then GoTo FastExit End If If i Mod 50 = 0 Then Application.StatusBar = "Processing File " & i DoEvents End If X(i, 1) = oFolder.Path X(i, 2) = Left(Fil.Name, InStrRev(Fil.Name, ".") - 1) X(i, 3) = Fil.Size X(i, 4) = Mid(Fil.Name, InStrRev(Fil.Name, ".") + 1) X(i, 5) = Fil.DateLastModified X(i, 6) = Fil.DateCreated X(i, 7) = DateDiff("d", Fil.DateLastModified, Now) Next 'Get subdirectories If TimeLimit = 0 Then Call RecursiveFolder(oFolder, 0) Else If Timer < (TimeLimit * 60 + StartTime) Then Call RecursiveFolder(oFolder, TimeLimit * 60 + StartTime) End If FastExit: Range("A:G") = X If i < 65535 Then Range(Cells(i + 1, "A"), Cells(65536, "A")).EntireRow.Delete Range("1:1").Font.Bold = True Rows("2:2").Select ActiveWindow.FreezePanes = True Range("a1").Activate Set FSO = Nothing Set objShell = Nothing Set oFolder = Nothing Set objFolder = Nothing Set objFolderItem = Nothing Set Fil = Nothing Application.StatusBar = "" Application.ScreenUpdating = True End Sub Sub RecursiveFolder(xFolder, TimeTest As Long) Dim SubFld For Each SubFld In xFolder.SubFolders Set oFolder = FSO.GetFolder(SubFld) Set objFolder = objShell.Namespace(SubFld.Path) On Error Resume Next For Each Fil In SubFld.Files Set objFolder = objShell.Namespace(oFolder.Path) 'Problem with objFolder at times If Not objFolder Is Nothing Then Set objFolderItem = objFolder.ParseName(Fil.Name) i = i + 1 If i Mod 20 = 0 And TimeTest < 0 And Timer TimeTest Then Exit Sub End If If i Mod 50 = 0 Then Application.StatusBar = "Processing File " & i DoEvents End If X(i, 1) = SubFld.Path X(i, 2) = Left(Fil.Name, InStrRev(Fil.Name, ".") - 1) X(i, 3) = Fil.Size X(i, 4) = Mid(Fil.Name, InStrRev(Fil.Name, ".") + 1) X(i, 5) = Fil.DateLastModified X(i, 6) = Fil.DateCreated X(i, 7) = DateDiff("d", Fil.DateLastModified, Now) Else Debug.Print Fil.Path & " " & Fil.Name End If Next Call RecursiveFolder(SubFld, TimeTest) Next End Sub Function BrowseForFolder(Optional OpenAt As Variant) As Variant 'Function purpose: To Browser for a user selected folder. 'If the "OpenAt" path is provided, open the browser at that directory 'NOTE: If invalid, it will open at the Desktop level Dim ShellApp As Object 'Create a file browser window at the default folder Set ShellApp = CreateObject("Shell.Application"). _ BrowseForFolder(0, "Please choose a folder", 0, OpenAt) 'Set the folder to that selected. (On error in case cancelled) On Error Resume Next BrowseForFolder = ShellApp.self.Path On Error GoTo 0 'Destroy the Shell Application Set ShellApp = Nothing 'Check for invalid or non-entries and send to the Invalid error 'handler if found 'Valid selections can begin L: (where L is a letter) or '\\ (as in \\servername\sharename. All others are invalid 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: 'If it was determined that the selection was invalid, set to False BrowseForFolder = False End Function |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Adapt this Directory Listing working code to insert a file name pattern prompt.
You have to do something like this after getting the file spec from the user
maybe using Inputbox: For Each Fil In oFolder.Files If Fil.Name Like "*.xl*" Then "u473" wrote in message ... The following code is a perfectly working Directory Listing. I adapted it to see all the properties I may need to filter. I do not know if it could be improved but I am happy with it. Now, I would like now to insert separate prompts for the file name pattern like *Cost* and extension type like mdb or accdb for instance. I do not know exactly where I would insert the prompts and process the If tests. Help appreciated, J.P. . Public X() Public i As Long Public objShell, objFolder, objFolderItem Public FSO, oFolder, Fil Sub MainExtractData() 'Code source : http://www.vbaexpress.com/kb/getarticle.php?kb_id=405 Dim NewSht As Worksheet Dim MainFolderName As String Dim TimeLimit As Long, StartTime As Double ReDim X(1 To 65536, 1 To 7) Set objShell = CreateObject("Shell.Application") TimeLimit = Application.InputBox("Please enter the maximum time that you wish this code to run for in minutes" & vbNewLine & vbNewLine & _ "Leave this at zero for unlimited runtime", "Time Check box", 0) StartTime = Timer Application.ScreenUpdating = False MainFolderName = BrowseForFolder() Set NewSht = ThisWorkbook.Sheets.Add X(1, 1) = "Path" X(1, 2) = "File Name" X(1, 3) = "Size" X(1, 4) = "Type" X(1, 5) = "Modified" X(1, 6) = "Created" X(1, 7) = "Age" ' File Age in Days from Modified Date to Now i = 1 Set FSO = CreateObject("scripting.FileSystemObject") Set oFolder = FSO.GetFolder(MainFolderName) 'Error handling to stop the obscure error that occurs at time when retrieving DateLastAccessed On Error Resume Next For Each Fil In oFolder.Files Set objFolder = objShell.Namespace(oFolder.Path) Set objFolderItem = objFolder.ParseName(Fil.Name) i = i + 1 If i Mod 20 = 0 And TimeLimit < 0 And Timer (TimeLimit * 60 + StartTime) Then GoTo FastExit End If If i Mod 50 = 0 Then Application.StatusBar = "Processing File " & i DoEvents End If X(i, 1) = oFolder.Path X(i, 2) = Left(Fil.Name, InStrRev(Fil.Name, ".") - 1) X(i, 3) = Fil.Size X(i, 4) = Mid(Fil.Name, InStrRev(Fil.Name, ".") + 1) X(i, 5) = Fil.DateLastModified X(i, 6) = Fil.DateCreated X(i, 7) = DateDiff("d", Fil.DateLastModified, Now) Next 'Get subdirectories If TimeLimit = 0 Then Call RecursiveFolder(oFolder, 0) Else If Timer < (TimeLimit * 60 + StartTime) Then Call RecursiveFolder(oFolder, TimeLimit * 60 + StartTime) End If FastExit: Range("A:G") = X If i < 65535 Then Range(Cells(i + 1, "A"), Cells(65536, "A")).EntireRow.Delete Range("1:1").Font.Bold = True Rows("2:2").Select ActiveWindow.FreezePanes = True Range("a1").Activate Set FSO = Nothing Set objShell = Nothing Set oFolder = Nothing Set objFolder = Nothing Set objFolderItem = Nothing Set Fil = Nothing Application.StatusBar = "" Application.ScreenUpdating = True End Sub Sub RecursiveFolder(xFolder, TimeTest As Long) Dim SubFld For Each SubFld In xFolder.SubFolders Set oFolder = FSO.GetFolder(SubFld) Set objFolder = objShell.Namespace(SubFld.Path) On Error Resume Next For Each Fil In SubFld.Files Set objFolder = objShell.Namespace(oFolder.Path) 'Problem with objFolder at times If Not objFolder Is Nothing Then Set objFolderItem = objFolder.ParseName(Fil.Name) i = i + 1 If i Mod 20 = 0 And TimeTest < 0 And Timer TimeTest Then Exit Sub End If If i Mod 50 = 0 Then Application.StatusBar = "Processing File " & i DoEvents End If X(i, 1) = SubFld.Path X(i, 2) = Left(Fil.Name, InStrRev(Fil.Name, ".") - 1) X(i, 3) = Fil.Size X(i, 4) = Mid(Fil.Name, InStrRev(Fil.Name, ".") + 1) X(i, 5) = Fil.DateLastModified X(i, 6) = Fil.DateCreated X(i, 7) = DateDiff("d", Fil.DateLastModified, Now) Else Debug.Print Fil.Path & " " & Fil.Name End If Next Call RecursiveFolder(SubFld, TimeTest) Next End Sub Function BrowseForFolder(Optional OpenAt As Variant) As Variant 'Function purpose: To Browser for a user selected folder. 'If the "OpenAt" path is provided, open the browser at that directory 'NOTE: If invalid, it will open at the Desktop level Dim ShellApp As Object 'Create a file browser window at the default folder Set ShellApp = CreateObject("Shell.Application"). _ BrowseForFolder(0, "Please choose a folder", 0, OpenAt) 'Set the folder to that selected. (On error in case cancelled) On Error Resume Next BrowseForFolder = ShellApp.self.Path On Error GoTo 0 'Destroy the Shell Application Set ShellApp = Nothing 'Check for invalid or non-entries and send to the Invalid error 'handler if found 'Valid selections can begin L: (where L is a letter) or '\\ (as in \\servername\sharename. All others are invalid 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: 'If it was determined that the selection was invalid, set to False BrowseForFolder = False End Function |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
File Listing in a Directory | Excel Programming | |||
Listing Active Directory groups that have directory access rights | Excel Programming | |||
Directory listing | Excel Discussion (Misc queries) | |||
How do I insert the directory path in my Excel file? | Excel Worksheet Functions | |||
Unix Directory/File Listing | Excel Programming |