I want to generate a list of files - including properties - in a folder. The Excel file with the macro will be in the same folder as the files it works with.
Problem is the Excel file and all other files will be synced between different Windows computers, so the folder path of the attached macro must be relative because it's different on every machine.
Const STRFOLDER As String = "D:\GIS-Projekte_Sync\"
Tried ideas (like "\" or "..\" etc.), searched forums.
Complete script:
Public Sub Auto_Open()
Const STRFOLDER As String = "D:\GIS-Projekte_Sync\"
Dim objShell As Object, objFolder As Object
Dim bytIndex As Byte, intColumn As Integer, lngRow As Long
Dim varName, arrHeaders(37)
If Dir(STRFOLDER, 16) = "" Then
MsgBox "Der Ordner " & STRFOLDER & " wurde nicht gefunden!", 64, "Hinweis"
Exit Sub
End If
Application.ScreenUpdating = False
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(STRFOLDER)
intColumn = 1
For bytIndex = 0 To 37
arrHeaders(bytIndex) = objFolder.GetDetailsOf(varName, bytIndex)
Cells(1, intColumn + bytIndex) = arrHeaders(bytIndex)
Next
Rows(1).Font.Bold = True
lngRow = 2
For Each varName In objFolder.Items
For bytIndex = 0 To 37
Cells(lngRow, intColumn + bytIndex) = objFolder.GetDetailsOf(varName, bytIndex)
Next
lngRow = lngRow + 1
Next
Columns.AutoFit
Set objShell = Nothing
Set objFolder = Nothing
Application.ScreenUpdating = True
End Sub
To answer my own question: You have to define STRFOLDER as Variant. Then you can use "ThisWorkbook.path" to get the folder location.
Here the complete macro:
Public Sub Auto_Open()
Dim STRFOLDER As Variant
Dim objShell As Object, objFolder As Object
Dim bytIndex As Byte, intColumn As Integer, lngRow As Long
Dim varName, arrHeaders(37)
STRFOLDER = ThisWorkbook.path & "\"
If Dir(STRFOLDER, 16) = "" Then
MsgBox "Der Ordner " & STRFOLDER & " wurde nicht gefunden!", 64, "Hinweis"
Exit Sub
End If
Application.ScreenUpdating = False
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(STRFOLDER)
intColumn = 1
For bytIndex = 0 To 37
arrHeaders(bytIndex) = objFolder.GetDetailsOf(varName, bytIndex)
Cells(1, intColumn + bytIndex) = arrHeaders(bytIndex)
Next
Rows(1).Font.Bold = True
lngRow = 2
For Each varName In objFolder.Items
For bytIndex = 0 To 37
Cells(lngRow, intColumn + bytIndex) = objFolder.GetDetailsOf(varName, bytIndex)
Next
lngRow = lngRow + 1
Next
Columns.AutoFit
Set objShell = Nothing
Set objFolder = Nothing
Application.ScreenUpdating = True
End Sub
ThisWorkbook.Path gives you the path for the current file so you can use that if relative paths are not working for you. You cannot however use CONST with the path, you will have to use a standard variable.
The other thing you need to remember is that paths in VBA may now be URI's and this doesn't always play nicely with the older parts of the code such as DIR. For example, if the file comes from Office 365 (e.g. OneDrive for Business), the path will be a URL and DIR will fail.
Related
I am using the following code to list all files in a host folder and it's sub folders. The code works great but, do you know how I can update the code to also list some the file attributes.
Sub file_list()
Call ListFilesInFolder("W:\ISO 9001\INTEGRATED_PLANNING\", True)
End Sub
Sub ListFilesInFolder(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean)
Dim FSO As Object
Dim SourceFolder As Object
Dim SubFolder As Object
Dim FileItem As Object
Dim r As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.getFolder(SourceFolderName)
r = Range("A65536").End(xlUp).Row + 1
For Each FileItem In SourceFolder.Files
Cells(r, 1).Formula = FileItem.Name
r = r + 1
X = SourceFolder.Path
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.Subfolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Function GetFileOwner(ByVal FilePath As String, ByVal FileName As String)
Dim objFolder As Object
Dim objFolderItem As Object
Dim objShell As Object
FileName = StrConv(FileName, vbUnicode)
FilePath = StrConv(FilePath, vbUnicode)
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(StrConv(FilePath, vbFromUnicode))
If Not objFolder Is Nothing Then
Set objFolderItem = objFolder.ParseName(StrConv(FileName, vbFromUnicode))
End If
If Not objFolderItem Is Nothing Then
GetFileOwner = objFolder.GetDetailsOf(objFolderItem, 8)
Else
GetFileOwner = ""
End If
Set objShell = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
End Function
What I would really like to see is;
Column A = Host folder/subfolder
Column B = File name
Column C = hyperlink to file
Is this possible?
I do have a code that created hyperlinks but, I do not know how to add to the existing code.
Sub startIt()
Dim FileSystem As Object
Dim HostFolder As String
HostFolder = "W:\ISO 9001\INTEGRATED_PLANNING\"
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
End Sub
Sub DoFolder(Folder)
Dim SubFolder
For Each SubFolder In Folder.Subfolders
DoFolder SubFolder
Next
i = Cells(Rows.Count, 1).End(xlUp).Row + 1
Dim File
For Each File In Folder.Files
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), Address:= _
File.Path, TextToDisplay:=File.Name
i = i + 1
Next
End Sub
You can see the list of properties that the File Object supports here: https://msdn.microsoft.com/en-us/library/1ft05taf(v=vs.84).aspx
So you can enhance your code, where it is taking the .Name property and putting that in a cell formula, to do something similar with other properties, such as the .Type of the file.
For Each FileItem In SourceFolder.Files
Cells(r, 1).Formula = FileItem.Name
Cells(r, 2).Value = FileItem.Type
ActiveSheet.Hyperlinks.Add Anchor:=Cells(r, 3), Address:= _
FileItem.Path, TextToDisplay:=FileItem.Name
r = r + 1
X = SourceFolder.Path
Next FileItem
n.b. I've used Value instead of Formula, but in this case the result will be the same.
In a similar manner, you can add another Cells(r, 3).Value = line to set the value of cell in the current row r and column 3 to whatever your hyperlink is.
I wrote a little script for this purpose to my colleague for a time ago...
See my code below:
Sub FolderNames()
'Written by Daniel Elmnas Last update 2016-02-17
Application.ScreenUpdating = False
Dim xPath As String
Dim xWs As Worksheet
Dim fso As Object, j As Long, folder1 As Object
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose the folder"
.Show
End With
On Error Resume Next
xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
Application.Workbooks.Add
Set xWs = Application.ActiveSheet
xWs.Cells(1, 1).Value = xPath
xWs.Cells(2, 1).Resize(1, 5).Value = Array("Subfolder", "Hostfolder", "Filename", "Date Created", "Date Last Modified")
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder1 = fso.getFolder(xPath)
getSubFolder folder1
xWs.Cells(2, 1).Resize(1, 5).Interior.Color = 65535
xWs.Cells(2, 1).Resize(1, 5).EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
Sub getSubFolder(ByRef prntfld As Object)
Dim SubFolder As Object
Dim subfld As Object
Dim xRow As Long
For Each SubFolder In prntfld.SubFolders
xRow = Range("A1").End(xlDown).Row + 1
Cells(xRow, 1).Resize(1, 5).Value = Array(SubFolder.Path, Left(SubFolder.Path, InStrRev(SubFolder.Path, "\")), SubFolder.Name, SubFolder.DateCreated, SubFolder.DateLastModified)
Next SubFolder
For Each subfld In prntfld.SubFolders
getSubFolder subfld
Next subfld
End Sub
Here is the result:
You can modify it a bit though.
If you example dont want to use a window-dialog and instead use
"W:\ISO 9001\INTEGRATED_PLANNING\"
Cheers!
Given a folder tree:
c:\example\
c:\example\2014-01-01\
c:\example\2014-01-01\Entered\
c:\example\2014-01-02\
c:\example\2014-01-02\Entered
etc.
I want to count the PDF files in the tree, but excluding any in the "Entered\" subfolders.
Is this possible even with VBA? Ultimately this count needs to be spit out onto an excel sheet.
copy all the code in an Excel-VBA Module. If you want to use a button then you should use CntFiles() on the button. But if you don't want to use a button then you can use fCount(strPath) as a formula on the Worksheet i.e =fCount("your-path"), the parameter is String so make it double-quoted when using on Worksheet.
Function fCount(strPath)
Dim fCnt As Integer
fCnt = ShowFolderList(strPath)
fCount = fCnt
End Function
Sub CntFiles()
Dim strPath As String
strPath = "A:\Asif\Answers\abc"
ShowFolderList (strPath)
End Sub
Function ShowFolderList(Path)
Dim fso, folder, subFlds, fld
Dim tFiles As Integer
tFiles = ShowFilesList(Path)
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(Path)
Set subFlds = folder.SubFolders
For Each fld In subFlds
If fld.Name = "Entered" Then
GoTo SkipFld:
Else
Path = fld.Path
tFiles = tFiles + ShowFilesList(Path)
End If
SkipFld:
Next
'MsgBox tFiles & " files"
ShowFolderList = tFiles
End Function
Function ShowFilesList(folderspec)
Dim fso, f, f1, fc, s
Dim Cnt As Integer
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(folderspec)
Set fc = f.Files
For Each f1 In fc
If GetAnExtension(f1) = "pdf" Then
Cnt = Cnt + 1
Else
End If
Next
ShowFilesList = Cnt
End Function
Function GetAnExtension(DriveSpec)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
GetAnExtension = fso.GetExtensionName(DriveSpec)
End Function
This code will count all the files in the specified folder as well as sub-folders excluding folder named "Entered" as you specified.
This code gives you a nice overview in an excel sheet:
Sub start()
Application.ScreenUpdating = False
Dim FolderName As String
Sheets("fldr").Select
Cells(1, 1).Value = 2
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
On Error Resume Next
FolderName = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With
ListFolders (FolderName)
Application.ScreenUpdating = True
MsgBox "Done" & vbCrLf & "Total files found: " & Cells(1, 1).Value
Cells(1, 1).Value = "Source"
Cells(1, 2).Value = "Folder"
Cells(1, 3).Value = "Subfolder"
Cells(1, 4).Value = "FileCount"
End Sub
Sub ListFolders(Fldr As String)
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
Dim fl1
Set fl1 = CreateObject("Scripting.FileSystemObject")
Dim fl2
Set fl2 = CreateObject("Scripting.FileSystemObject")
Set fl1 = fs.GetFolder(Fldr)
For Each fl2 In fl1.SubFolders
Cells(Cells(1, 1).Value, 1).Value = Replace(Fldr, fl1.Name, "")
Cells(Cells(1, 1).Value, 2).Value = fl1.Name
Cells(Cells(1, 1).Value, 3).Value = fl2.Name
Cells(Cells(1, 1).Value, 4).Value = CountFiles(Fldr & "\" & fl2.Name)
Cells(1, 1).Value = Cells(1, 1).Value + 1
ListFolders fl2.Path
Next
End Sub
Function CountFiles(Fldr As String)
Dim fso As Object
Dim objFiles As Object
Dim obj As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFiles = fso.GetFolder(Fldr).Files
CountFiles = objFiles.Count
Set objFiles = Nothing
Set fso = Nothing
Set obj = Nothing
End Function
I have a file name of a pdf that I want to search for in a folder on a shared network drive \\Share\Projects. The pdf will be in one of the subfolders under projects. I then want to return the entire file path of the pdf into a cell (eg \\Share\Projects\Subfolder\Another subfolder\thisone.pdf).
I have started the code but can't figure out how to search a file system:
Sub InsertPath()
Dim PONumber As String
PONumber = InputBox("PO Number:", "PO Number")
'search for order
Dim myFolder As Folder
Dim myFile As File
'This bit doesn't work
Set myFolder = "\\Share\Projects"
For Each myFile In myFolder.Files
If myFile.Name = "PO" & PONumber & ".pdf" Then
'I have absolutely no idea how to do this bit
End If
Next
End Sub
Am I on the right track or is my code completely wrong?
get list of subdirs in vba
slighly modified the above post.
Public Arr() As String
Public Counter As Long
Sub LoopThroughFilePaths()
Dim myArr
Dim i As Long
Dim j As Long
Dim MyFile As String
Const strPath As String = "C:\Personal\" ' change it as per your needs
myArr = GetSubFolders(strPath)
Application.ScreenUpdating = False
Range("A1:B1") = Array("text file", "path")
For j = LBound(Arr) To UBound(Arr)
MyFile = Dir(myArr(j) & "\*.pdf")
Do While Len(MyFile) <> 0
i = i + 1
Cells(i, 1) = MyFile
Cells(i, 2) = myArr(j)
MyFile = Dir
Loop
Next j
Application.ScreenUpdating = True
End Sub
Function GetSubFolders(RootPath As String)
Dim fso As Object
Dim fld As Object
Dim sf As Object
Dim myArr
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(RootPath)
For Each sf In fld.SUBFOLDERS
Counter = Counter + 1
ReDim Preserve Arr(Counter)
Arr(Counter) = sf.Path
myArr = GetSubFolders(sf.Path)
Next
GetSubFolders = Arr
Set sf = Nothing
Set fld = Nothing
Set fso = Nothing
End Function
Well, your folder declaration isn't set against a filesystemobject so it can't find the folder. And because it's a network location, you may need to map a network drive first so that it's a secure link.
So here's an updated version of your code.
EDIT - to OP's conditions.
Dim PONumber As String
Sub InsertPath()
PONumber = InputBox("PO Number:", "PO Number")
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim Servershare As String
ServerShare = "S:\"
Dim Directory As Object
Set Directory = fso.GetFolder(ServerShare)
Subfolderstructure Directory
End Sub
Function Subfolderstructure(Directory As Object)
For Each oFldr in Directory.SubFolders
For Each FileName In oFldr.Files
If FileName.Name = "PO" & PONumber & ".pdf" Then
sheets("Sheet1").range("A1").value = ServerShare & "\PO" & PONumber & ".pdf"
Exit For
End If
Next
Dim sbfldrs : Set sbfldrs = ofldr.SubFolders
If isarray(sbfldrs) then
Subfolderstructure ofldr
End if
Next
'Cleanup
Set FileName = Nothing
Set Directory = Nothing
Set fso = Nothing
End Function
I have not tested this code. Try it out and let me know how it works.
I have worked on this for a while. It's my first Excel VBA macro and I think I am almost there. I just can't seem to find a way to get the information I need from my function or I can't get my function to give me the right information.
I need a macro that will search through a selected folder and its sub-folders for excel workbooks that have specific sheet names contained with in then out put the paths to an excel spreadsheet. Currently my code will either only find the files in a single folder or it will list all the files indiscriminately. Now the code is a bit of a mess because i am unsure of which parts I need and which parts I don't.
Option Explicit
Public ObjFolder As Object
Public objFso As Object
Public objFldLoop As Object
Public lngCounter As Long
Public objFl As Object
Sub ImportSheet()
Dim i As Integer
Dim SourceFolder As String
Dim FileList As Variant
Dim GrabSheet As String
Dim FileType As String
Dim ActWorkBk As String
Dim ImpWorkBk As String
Dim NoImport As Boolean
Dim FileToWriteTo As Variant
Dim xRow As Long
Dim xDirect$, xFname$, InitialFoldr$
Dim MyDir As String, myList()
'Startup folder to begin filedialog search
InitialFoldr$ = "C:"
'Define filetype
FileType = "*.xlsx"
'Define sheetname to copy
GrabSheet = Application.InputBox(prompt:="Please enter name of sheet you wish to find.", Title:="Specify Sheet Name")
'open dialog for user to select a folder to search
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr$
If .Show = True Then
MyDir = .SelectedItems(1)
End If
End With
On Error Resume Next
myList = SearchFiles(MyDir, "*.xlsx", 0, myList())
If Err = 0 Then
'If user selects folder count the items to search
xDirect$ = MyDir & "\"
xFname$ = Dir(xDirect$, 8)
'Creates list with filenames
FileList = ListFiles(xDirect$ & FileType)
'Imports data
Application.ScreenUpdating = False
ActWorkBk = ActiveWorkbook.Name
NoImport = False
'Clear contents of Active sheet and set active cell to A1
Sheets(1).UsedRange.ClearContents
Sheets(1).Select
Range("A1").Select
For i = 1 To UBound(FileList)
'Opens file
Workbooks.Open (xDirect$ & FileList(i))
ImpWorkBk = ActiveWorkbook.Name
'Checks to see if the specific sheet exists in the workbook
On Error Resume Next
ActiveWorkbook.Sheets(GrabSheet).Select
If Err > 0 Then
NoImport = True
GoTo nxt
End If
Err.Clear
On Error GoTo 0
xFname$ = Dir(xDirect$ & FileList(i))
Do While xFname$ <> ""
ThisWorkbook.Activate
ActiveCell.Offset(xRow) = xDirect$ & xFname$
xRow = xRow + 1
xFname$ = Dir
Loop
'Copies sheet
'ActiveWorkbook.Sheets(GrabSheet).Copy after:=Workbooks(ActWorkBk).Sheets(Workbooks(ActWorkBk).Sheets.Count)
'Renames the imported sheet
On Error Resume Next
ActiveSheet.Name = "Specs with " & GrabSheet
Err.Clear
On Error GoTo 0
nxt:
'Closes importfile
Workbooks(ImpWorkBk).Activate
Application.DisplayAlerts = False
ActiveWorkbook.Saved = True
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
'Workbooks(ActWorkBk).Activate
Next i
'Error if some sheets were not found
' If NoImport = True Then MsgBox "Some of the files did not contain the sheet " & GrabSheet
Application.ScreenUpdating = True
Else
MsgBox "No file found"
End If
On Error GoTo 0
' End If
'End With
'End Function
End Sub
'WITH SUBFOLDERS - Function that creates an array with all the files in the folder
Private Function SearchFiles(MyDir As String, myFileName As String, n As Long, myList()) As Variant
Dim fso As Object, myFolder As Object, myFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
For Each myFile In fso.getfolder(MyDir).Files
If (Not myFile.Name Like "~$*") * (myFile.Name <> ThisWorkbook.Name) _
* (myFile.Name Like myFileName) Then
n = n + 1
ReDim Preserve myList(1 To 2, 1 To n)
myList(1, n) = MyDir
myList(2, n) = myFile.Name
End If
Next
For Each myFolder In fso.getfolder(MyDir).subfolders
SearchFiles = SearchFiles(myFolder.Path, myFileName, n, myList)
Next
SearchFiles = IIf(n > 0, myList, "")
End Function
'WITHOUT SUBFOLDERS - Function that creates an array with all the files in the folder
Function ListFiles(Source As String) As Variant
Dim GetFileNames() As Variant
Dim i As Integer
Dim FileName As String
On Error GoTo ErrHndlr
i = 0
FileName = Dir(Source)
If FileName = "" Then GoTo ErrHndlr
'Loops until no more mathing files are found
Do While FileName <> ""
i = i + 1
ReDim Preserve GetFileNames(1 To i)
GetFileNames(i) = FileName
FileName = Dir()
Loop
ListFiles = GetFileNames
On Error GoTo 0
Exit Function
'If error
ErrHndlr:
ListFiles = False
On Error GoTo 0
End Function
This will work right now to give a list using the "ListFiles" Function.
But I can't seem to figure out how to get it to out put a list using the "SearchFiles" Function. Which, ultimately,is what I need it to do.
Please help i feel like I am so close!!!
Ok i figured it out. I was having trouble with the syntax to access my array of arrays. here is the code that ended up doing the trick.
Option Explicit
Public ObjFolder As Object
Public objFso As Object
Public objFldLoop As Object
Public lngCounter As Long
Public objFl As Object
Sub ImportSheet()
Dim i As Integer
Dim GrabSheet As String
Dim ActWorkBk As String
Dim ImpWorkBk As String
Dim NoImport As Boolean
Dim xRow As Long
Dim xFname As String
Dim InitialFoldr As String
Dim MyDir As String, myList()
'Startup folder to begin filedialog search
InitialFoldr = "C:\Users\george.EASYWAY\Desktop\TEST1\"
'Define sheetname to copy
GrabSheet = Application.InputBox(prompt:="Please enter name of sheet you wish to find.", Default:="snagit", Title:="Specify Sheet Name")
'open dialog for user to select a folder to search
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr
If .Show = True Then
MyDir = .SelectedItems(1)
End If
End With
On Error Resume Next
myList = SearchFiles(MyDir, "*.xlsx", 0, myList())
If Err = 0 Then
'Imports data
Application.ScreenUpdating = False
ActWorkBk = ActiveWorkbook.Name
NoImport = False
'Clear contents of Active sheet and set active cell to A1
Sheets(1).UsedRange.ClearContents
Sheets(1).Select
Range("A1").Select
For i = 1 To UBound(myList, 2)
'Opens file
Workbooks.Open (myList(1, (i)) & "\" & (myList(2, (i))))
ImpWorkBk = ActiveWorkbook.Name
'Checks to see if the specific sheet exists in the workbook
On Error Resume Next
ActiveWorkbook.Sheets(GrabSheet).Select
If Err > 0 Then
NoImport = True
GoTo nxt
End If
Err.Clear
On Error GoTo 0
xFname = Dir(myList(1, (i)) & "\" & (myList(2, (i))))
Do While xFname <> ""
ThisWorkbook.Activate
ActiveCell.Offset(xRow) = (myList(1, (i)) & "\" & (myList(2, (i))))
xRow = xRow + 1
xFname = Dir
Loop
'Renames the imported sheet
On Error Resume Next
ActiveSheet.Name = "Specs with " & GrabSheet
Err.Clear
On Error GoTo 0
nxt:
'Closes importfile
Workbooks(ImpWorkBk).Activate
Application.DisplayAlerts = False
ActiveWorkbook.Saved = True
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
'Workbooks(ActWorkBk).Activate
Next i
'Error if some sheets were not found
' If NoImport = True Then MsgBox "Some of the files did not contain the sheet " & GrabSheet
Application.ScreenUpdating = True
Else
MsgBox "No file found"
End If
On Error GoTo 0
End Sub
'Function that creates an array with all the files in the folder with subfolders
Function SearchFiles(MyDir As String, myFileName As String, n As Long, myList()) As Variant
Dim fso As Object, myFolder As Object, myFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
For Each myFile In fso.getfolder(MyDir).Files
If (Not myFile.Name Like "~$*") * (myFile.Name <> ThisWorkbook.Name) _
* (myFile.Name Like myFileName) Then
n = n + 1
ReDim Preserve myList(1 To 2, 1 To n)
myList(1, n) = MyDir
myList(2, n) = myFile.Name
End If
Next
For Each myFolder In fso.getfolder(MyDir).subfolders
SearchFiles = SearchFiles(myFolder.Path, myFileName, n, myList)
Next
SearchFiles = IIf(n > 0, myList, "")
End Function
I want to get a list of all sub-directories within a directory.
If that works I want to expand it to a recursive function.
However my initial approach to get the subdirs fails. It simply shows everything including files:
sDir = Dir(sPath, vbDirectory)
Do Until LenB(sDir) = 0
Debug.Print sDir
sDir = Dir
Loop
The list starts with '..' and several folders and ends with '.txt' files.
EDIT:
I should add that this must run in Word, not Excel (many functions are not available in Word) and it is Office 2010.
EDIT 2:
One can determine the type of the result using
iAtt = GetAttr(sPath & sDir)
If CBool(iAtt And vbDirectory) Then
...
End If
But that gave me new problems, so that I am now using a code based on Scripting.FileSystemObject.
Updated July 2014: Added PowerShell option and cut back the second code to list folders only
The methods below that run a full recursive process in place of FileSearch which was deprecated in Office 2007. (The later two codes use Excel for output only - this output can be removed for running in Word)
Shell PowerShell
Using FSO with Dir for filtering file type. Sourced from this EE answer which sits behind the EE paywall. This is longer than what you asked for (a list of folders) but i think it is useful as it gives you an array of results to work further with
Using Dir. This example comes from my answer I supplied on another site
1. Using PowerShell to dump all folders below C:\temp into a csv file
Sub Comesfast()
X2 = Shell("powershell.exe Get-ChildItem c:\temp -Recurse | ?{ $_.PSIsContainer } | export-csv C:\temp\filename.csv", 1)
End Sub
2. Using FileScriptingObject to dump all folders below C:\temp into Excel
Public Arr() As String
Public Counter As Long
Sub LoopThroughFilePaths()
Dim myArr
Dim strPath As String
strPath = "c:\temp\"
myArr = GetSubFolders(strPath)
[A1].Resize(UBound(myArr, 1), 1) = Application.Transpose(myArr)
End Sub
Function GetSubFolders(RootPath As String)
Dim fso As Object
Dim fld As Object
Dim sf As Object
Dim myArr
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(RootPath)
For Each sf In fld.SUBFOLDERS
ReDim Preserve Arr(Counter)
Arr(Counter) = sf.Path
Counter = Counter + 1
myArr = GetSubFolders(sf.Path)
Next
GetSubFolders = Arr
Set sf = Nothing
Set fld = Nothing
Set fso = Nothing
End Function
3 Using Dir
Option Explicit
Public StrArray()
Public lngCnt As Long
Public b_OS_XP As Boolean
Public Enum MP3Tags
' See http://www.kixtart.org/forums/ubbthreads.php?ubb=showflat&Number=160880&page=1 for OS specific attribute lists
XP_Artist = 16
XP_AlbumTitle = 17
XP_SongTitle = 10
XP_TrackNumber = 19
XP_RecordingYear = 18
XP_Genre = 20
XP_Duration = 21
XP_BitRate = 22
Vista_W7_Artist = 13
Vista_W7_AlbumTitle = 14
Vista_W7_SongTitle = 21
Vista_W7_TrackNumber = 26
Vista_W7_RecordingYear = 15
Vista_W7_Genre = 16
Vista_W7_Duration = 17
Vista_W7_BitRate = 28
End Enum
Public Sub Main()
Dim objws
Dim objWMIService
Dim colOperatingSystems
Dim objOperatingSystem
Dim objFSO
Dim objFolder
Dim Wb As Workbook
Dim ws As Worksheet
Dim strobjFolderPath As String
Dim strOS As String
Dim strMyDoc As String
Dim strComputer As String
'Setup Application for the user
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'reset public variables
lngCnt = 0
ReDim StrArray(1 To 10, 1 To 1000)
' Use wscript to automatically locate the My Documents directory
Set objws = CreateObject("wscript.shell")
strMyDoc = objws.SpecialFolders("MyDocuments")
strComputer = "."
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
For Each objOperatingSystem In colOperatingSystems
strOS = objOperatingSystem.Caption
Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
If InStr(strOS, "XP") Then
b_OS_XP = True
Else
b_OS_XP = False
End If
' Format output sheet
Set Wb = Workbooks.Add(1)
Set ws = Wb.Worksheets(1)
ws.[a1] = Now()
ws.[a2] = strOS
ws.[a3] = strMyDoc
ws.[a1:a3].HorizontalAlignment = xlLeft
ws.[A4:J4].Value = Array("Folder", "File", "Artist", "Album Title", "Song Title", "Track Number", "Recording Year", "Genre", "Duration", "Bit Rate")
ws.Range([a1], [j4]).Font.Bold = True
ws.Rows(5).Select
ActiveWindow.FreezePanes = True
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strMyDoc)
' Start the code to gather the files
ShowSubFolders objFolder, True
ShowSubFolders objFolder, False
If lngCnt > 0 Then
' Finalise output
With ws.Range(ws.[a5], ws.Cells(5 + lngCnt - 1, 10))
.Value2 = Application.Transpose(StrArray)
.Offset(-1, 0).Resize(Rows.Count - 3, 10).AutoFilter
.Offset(-4, 0).Resize(Rows.Count, 10).Columns.AutoFit
End With
ws.[a1].Activate
Else
MsgBox "No files found!", vbCritical
Wb.Close False
End If
' tidy up
Set objFSO = Nothing
Set objws = Nothing
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.StatusBar = vbNullString
End With
End Sub
Sub ShowSubFolders(ByVal objFolder, bRootFolder As Boolean)
Dim objShell
Dim objShellFolder
Dim objShellFolderItem
Dim colFolders
Dim objSubfolder
'strName must be a variant, as ParseName does not work with a string argument
Dim strFname
Set objShell = CreateObject("Shell.Application")
Set colFolders = objFolder.SubFolders
Application.StatusBar = "Processing " & objFolder.Path
If bRootFolder Then
Set objSubfolder = objFolder
GoTo OneTimeRoot
End If
For Each objSubfolder In colFolders
'check to see if root directory files are to be processed
OneTimeRoot:
strFname = Dir(objSubfolder.Path & "\*.mp3")
Set objShellFolder = objShell.Namespace(objSubfolder.Path)
Do While Len(strFname) > 0
lngCnt = lngCnt + 1
If lngCnt Mod 1000 = 0 Then ReDim Preserve StrArray(1 To 10, 1 To (lngCnt + 1000))
Set objShellFolderItem = objShellFolder.ParseName(strFname)
StrArray(1, lngCnt) = objSubfolder
StrArray(2, lngCnt) = strFname
If b_OS_XP Then
StrArray(3, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_Artist)
StrArray(4, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_AlbumTitle)
StrArray(5, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_SongTitle)
StrArray(6, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_TrackNumber)
StrArray(7, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_RecordingYear)
StrArray(8, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_Genre)
StrArray(9, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_Duration)
StrArray(10, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_BitRate)
Else
StrArray(3, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_Artist)
StrArray(4, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_AlbumTitle)
StrArray(5, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_SongTitle)
StrArray(6, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_TrackNumber)
StrArray(7, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_RecordingYear)
StrArray(8, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_Genre)
StrArray(9, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_Duration)
StrArray(10, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_BitRate)
End If
strFname = Dir
Loop
If bRootFolder Then
bRootFolder = False
Exit Sub
End If
ShowSubFolders objSubfolder, False
Next
End Sub
You would be better off with the FileSystemObject. I reckon.
To call this you just need, say:
listfolders "c:\data"
Sub listfolders(startfolder)
''Reference Windows Script Host Object Model
''If you prefer, just Dim everything as Object
''and use CreateObject("Scripting.FileSystemObject")
Dim fs As New FileSystemObject
Dim fl1 As Folder
Dim fl2 As Folder
Set fl1 = fs.GetFolder(startfolder)
For Each fl2 In fl1.SubFolders
Debug.Print fl2.Path
listfolders fl2.Path
Next
End Sub
Here is a VBA solution, without using external objects.
Because of the limitations of the Dir() function you need to get the whole content of each folder at once, not while crawling with a recursive algorithm.
Function GetFilesIn(Folder As String) As Collection
Dim F As String
Set GetFilesIn = New Collection
F = Dir(Folder & "\*")
Do While F <> ""
GetFilesIn.Add F
F = Dir
Loop
End Function
Function GetFoldersIn(Folder As String) As Collection
Dim F As String
Set GetFoldersIn = New Collection
F = Dir(Folder & "\*", vbDirectory)
Do While F <> ""
If GetAttr(Folder & "\" & F) And vbDirectory Then GetFoldersIn.Add F
F = Dir
Loop
End Function
Sub Test()
Dim C As Collection, F
Debug.Print
Debug.Print "Files in C:\"
Set C = GetFilesIn("C:\")
For Each F In C
Debug.Print F
Next F
Debug.Print
Debug.Print "Folders in C:\"
Set C = GetFoldersIn("C:\")
For Each F In C
Debug.Print F
Next F
End Sub
EDIT
This version digs into subfolders and returns full path names instead of returning just the file or folder name.
Do NOT run the test with on the whole C drive!!
Function GetFilesIn(Folder As String, Optional Recursive As Boolean = False) As Collection
Dim F As String
Set GetFilesIn = New Collection
F = Dir(Folder & "\*")
Do While F <> ""
GetFilesIn.Add JoinPaths(Folder, F)
F = Dir
Loop
If Recursive Then
Dim SubFolder, SubFile
For Each SubFolder In GetFoldersIn(Folder)
If Right(SubFolder, 2) <> "\." And Right(SubFolder, 3) <> "\.." Then
For Each SubFile In GetFilesIn(CStr(SubFolder), True)
GetFilesIn.Add SubFile
Next SubFile
End If
Next SubFolder
End If
End Function
Function GetFoldersIn(Folder As String) As Collection
Dim F As String
Set GetFoldersIn = New Collection
F = Dir(Folder & "\*", vbDirectory)
Do While F <> ""
If GetAttr(Folder & "\" & F) And vbDirectory Then GetFoldersIn.Add JoinPaths(Folder, F)
F = Dir
Loop
End Function
Function JoinPaths(Path1 As String, Path2 As String) As String
JoinPaths = Replace(Path1 & "\" & Path2, "\\", "\")
End Function
Sub Test()
Dim C As Collection, F
Debug.Print
Debug.Print "Files in C:\"
Set C = GetFilesIn("C:\")
For Each F In C
Debug.Print F
Next F
Debug.Print
Debug.Print "Folders in C:\"
Set C = GetFoldersIn("C:\")
For Each F In C
Debug.Print F
Next F
Debug.Print
Debug.Print "All files in C:\"
Set C = GetFilesIn("C:\", True)
For Each F In C
Debug.Print F
Next F
End Sub
Here is a Simple version without using Scripting.FileSystemObject because I found it slow and unreliable. In particular the .Name method, was slowing everything down. Also I tested this in Excel but I don't think anything I used wouldn't be available in Word.
First some functions:
This joins two strings to create a file path, similar to os.path.join in python. It is useful for not needing to remember if you tacked on that "\" at the end of your path.
Const sep as String = "\"
Function pjoin(root_path As String, file_path As String) As String
If right(root_path, 1) = sep Then
pjoin = root_path & file_path
Else
pjoin = root_path & sep & file_path
End If
End Function
This create a collection of sub items of root directory root_path
Function subItems(root_path As String, Optional pat As String = "*", _
Optional vbtype As Integer = vbNormal) As Collection
Set subItems = New Collection
Dim sub_item As String
sub_item= Dir(pjoin(root_path, pat), vbtype)
While sub_item <> ""
subItems.Add (pjoin(root_path, sub_item))
sub_item = Dir()
Wend
End Function
This creates a collection of sub items in directory root_path that including folders and then removes items that are not folders from the collection. And it can optionally remove those nasty . and .. folders
Function subFolders(root_path As String, Optional pat As String = "", _
Optional skipDots As Boolean = True) As Collection
Set subFolders = subItems(root_path, pat, vbDirectory)
If skipDots Then
Dim dot As String
Dim dotdot As String
dot = pjoin(root_path, ".")
dotdot = dot & "."
Do While subFolders.Item(1) = dot _
Or subFolders.Item(1) = dotdot
subFolders.remove (1)
If subFolders.Count = 0 Then Exit Do
Loop
End If
For i = subFolders.Count To 1 Step -1
' This comparison could be replaced by and `fileExists` function
If Dir(subFolders.Item(i), vbNormal) <> "" Then
subFolders.remove (i)
End If
Next i
End Function
Finally is the recursive search function based on someone else function from this site that used Scripting.FileSystemObject I haven't done any comparison tests between it and the original. If I find that post again I will link it. Note collec is passed by reference so create a new collection and call this sub to populate it. Pass vbType:=vbDirectory for all sub folders.
Sub walk(root_path As String, ByRef collec as Collection, Optional pat As String = "*" _
Optional vbType as Integer = vbNormal)
Dim subF as Collection
Dim subD as Collection
Set subF = subItems(root_path, pat, vbType)
For Each sub_file In subF
collec.Add sub_file
Next sub_file
Set subD = subFolders(root_path)
For Each sub_folder In subD
walk sub_folder , collec, pat, vbType
Next sub_folder
End Sub
Late answer, but posting for others who might have a similar problem.
I had a similar challenge but had the restriction of not being able to use FileSystemObject. Therefore, I wrote a Class library that makes heavy use of the Dir() function to parse all the files and folders in a specified directory. It requires you to set no references to additional libraries in the VBA IDE. Although I wrote it for Excel, I tested and verified it runs in Word also.
You can use it to print a list of all folders like this:
Sub PrintFilesAndFolders(Directory As DirectoryManager, Optional indent As String)
'Helper method
Dim folder As DirectoryManager
Dim newIndent As String
For Each folder In Directory.Folders
Debug.Print indent & "+ " & folder.Name
newIndent = indent & " "
PrintFilesAndFolders folder, newIndent
Next folder
End Sub
Sub LoopThroughAllFilesAndFolders()
Dim dm As DirectoryManager
Set dm = New DirectoryManager
dm.Path = ThisDocument.Path & "\Sample Data Set"
PrintFilesAndFolders dm
End Sub
The example documentation shows how you can modify that script to include files too if you wanted.