26 | 02 | 2017

FileList by Extension

Organising a hard drive can be painful if you can't see the files though all the folders. With this code you can specify a extension and a folder to look in. Then it will create a new Excel sheet and adds all the file names an paths (including subfolders). This code can also be used to change files names or to open each file in a folder to modify. For this test a DWG extensions has been added. The code works also when this DWG is changed to whatever extension you like. Mp3, PDF, DXF, JPG, BMP etc.


Public DefaultRow As Long
Public objShell, objFolder, objFolderItem
Public FSO, oFolder, Fil
Public NewSht As Worksheet
Public FolderSelection As String
Public FileNameColumnNo, FilePathColumnNo, RowNo As Integer
Public FileExtension As String

'**Downloaded from VisibleVisual.com**
Public Sub GetFiles()
'Set the Default Row Number
FileExtension = "DWG"   'Extension to look for PDF, DWG, DXF, JPG, Mp3 etc...
FileNameColumnNo = 1    'Column were FileName is displayed
FilePathColumnNo = 2    'Column were FilePath is displayed
RowNo = 1               'Start Row
FolderSelection = "Select a folder that contain DWG files"
Dim oFolderName As String
oFolderName = Browse2FolderPath()
DefaultRow = 1
Set FSO = CreateObject("scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(oFolderName)
On Error Resume Next
For Each Fil In oFolder.Files
Set objFolder = objShell.Namespace(oFolder.Path)
Set objFolderItem = objFolder.ParseName(Fil.Name)
'Here you can select or change the kind of files you would like to add.
If UCase(Fil.Name) Like "*." & FileExtension Then
' On Error Resume Next
ActiveWorkbook.Worksheets(1).Cells(DefaultRow, FilePathColumnNo) = UCase(Fil.Name)
' On Error Resume Next
ActiveWorkbook.Worksheets(1).Cells(DefaultRow, FileNameColumnNo) = oFolder.Path
DefaultRow = DefaultRow + 1
End If
'Search extensions in subfolders in FolderSelection for FileExtension files
Call RecursiveFolder(oFolder)
RowNo = RowNo + 1
If IsEmpty(ActiveWorkbook.Worksheets(1).Cells(1, 1)) = True Then
MsgBox "There are no DWG files in folder: " & oFolder.Path
End If
MsgBox RowNo & " " & FileExtension & " files have been found and added to the Excel File"
Set FSO = Nothing
Set objShell = Nothing
Set oFolder = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
Set Fil = Nothing
End Sub

Sub RecursiveFolder(xFolder)
'This Sub searches for Extensions in subfolders
Dim SubFld
For Each SubFld In xFolder.SubFolders
Set oFolder = FSO.GetFolder(SubFld)
For Each Fil In SubFld.Files
Set objFolder = FSO.GetFolder(oFolder.Path)
'Problem with objFolder at times
If Not objFolder Is Nothing Then
If UCase(Fil.Name) Like "*." & FileExtension Then
On Error Resume Next
ActiveWorkbook.Worksheets(1).Cells(DefaultRow, FilePathColumnNo) = UCase(Fil.Name)
On Error Resume Next
ActiveWorkbook.Worksheets(1).Cells(DefaultRow, FileNameColumnNo) = oFolder.Path
DefaultRow = DefaultRow + 1
End If
Debug.Print Fil.Path & " " & Fil.Name
End If
Call RecursiveFolder(SubFld)
End Sub

Function Browse2FolderPath(Optional OpenDflt As VariantAs Variant
'This function opens the FolderDialog
'OpenPath is optional to set a default path
'If no defaultpath is found desktop will be opened as default.
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, FolderSelection, 0, OpenDflt)
'Set the folder to the selected path. (On error in case cancelled)
On Error Resume Next
Browse2FolderPath = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check to see if the folder is valid
Select Case Mid(Browse2FolderPath, 2, 1)
Case Is = ":"
If Left(Browse2FolderPath, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(Browse2FolderPath, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
'If it was determined that the selection was invalid, set to False
Browse2FolderPath = False
End Function

Sign up now and upload your code to the website.

Help us to continue.....
Articles View Hits
Latest Articles