24 | 05 | 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.

[code]

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
Next
 
'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
Else
Debug.Print Fil.Path & " " & Fil.Name
End If
Next
Call RecursiveFolder(SubFld)
Next
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
Invalid:
'If it was determined that the selection was invalid, set to False
Browse2FolderPath = False
End Function
 [/code]
Login

Sign up now and upload your code to the website.

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