PDA

View Full Version : Folder/Subfolder list help.



iscariot_0ne
05-14-2009, 06:17 AM
I've spent 2 days searching for code that will create a list of folders and subfolders from a specific folder. What I want to do is take my music library and have it listed out by artist then album. I have found numerous codes for directory lists, but they are all too detailed and directed at getting file information and all i'm looking to do is list out the folders and subfolders from the music folder, and possible indent the subfolders to keep them seperated so you can tell the artist folder from the albums folders.

I am a noob, I don't know anything about VBA code other than how to copy and paste it into a module to use it. I'm hoping you don't hold that against me and can help. I'm using excel 2007 if that helps at all.

Bob Phillips
05-14-2009, 06:43 AM
Is this any good?



Option Explicit

Private cnt As Long
Private arfiles
Private level As Long

Sub Folders()
Dim i As Long
Dim sFolder As String
Dim iStart As Long
Dim iEnd As Long
Dim fOutline As Boolean

arfiles = Array()
cnt = -1
level = 1

sFolder = "E:\"
ReDim arfiles(2, 0)
If sFolder <> "" Then
SelectFiles sFolder
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Files").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Worksheets.Add.Name = "Files"
With ActiveSheet
For i = LBound(arfiles, 2) To UBound(arfiles, 2)
If arfiles(0, i) = "" Then
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If
With .Cells(i + 1, arfiles(2, i))
.Value = arfiles(1, i)
.Font.Bold = True
End With
iStart = i + 1
iEnd = iStart
fOutline = False
Else
.Hyperlinks.Add Anchor:=.Cells(i + 1, arfiles(2, i)), _
Address:=arfiles(0, i), _
TextToDisplay:=arfiles(1, i)
iEnd = iEnd + 1
fOutline = True
End If
Next
.Columns("A:Z").ColumnWidth = 5
End With
End If
'just in case there is another set to group
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If

Columns("A:Z").ColumnWidth = 5
ActiveSheet.Outline.ShowLevels RowLevels:=1
ActiveWindow.DisplayGridlines = False

End Sub

'-----------------------------------------------------------------------
Sub SelectFiles(Optional sPath As String)
'-----------------------------------------------------------------------
Static FSO As Object
Dim oSubFolder As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim arPath

If FSO Is Nothing Then
Set FSO = CreateObject("Scripting.FileSystemObject")
End If

If sPath = "" Then
sPath = CurDir
End If

arPath = Split(sPath, "\")
cnt = cnt + 1
ReDim Preserve arfiles(2, cnt)
arfiles(0, cnt) = ""
arfiles(1, cnt) = arPath(level - 1)
arfiles(2, cnt) = level

Set oFolder = FSO.GetFolder(sPath)
Set oFiles = oFolder.Files
For Each oFile In oFiles
cnt = cnt + 1
ReDim Preserve arfiles(2, cnt)
arfiles(0, cnt) = oFolder.Path & "\" & oFile.Name
arfiles(1, cnt) = oFile.Name
arfiles(2, cnt) = level + 1
Next oFile

level = level + 1
For Each oSubFolder In oFolder.Subfolders
SelectFiles oSubFolder.Path
Next
level = level - 1

End Sub

iscariot_0ne
05-14-2009, 06:56 AM
Excel locks up when I run this.

iscariot_0ne
05-14-2009, 07:03 AM
actually, on the 3rd run, i've gotten this error

runtime error 70:
permission denied

Bob Phillips
05-14-2009, 08:39 AM
Are some of the directories protected against you?

iscariot_0ne
05-14-2009, 09:17 AM
No, its my personal external hard drive that I keep all the files on.. i do wonder though, there are a few iTunes purchased files that would require an email address if opened on another computer, do you think that would create the conflict? but if it's only reading the folder names i wouldn't think that would be an issue? hope that helps.

Bob Phillips
05-14-2009, 11:47 AM
Try this variation




Private cnt As Long
Private arfiles
Private level As Long

Sub Folders()
Dim i As Long
Dim sFolder As String
Dim iStart As Long
Dim iEnd As Long
Dim fOutline As Boolean

arfiles = Array()
cnt = -1
level = 1

sFolder = "C:\test"
ReDim arfiles(2, 0)
If sFolder <> "" Then
SelectFiles sFolder
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Files").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Worksheets.Add.Name = "Files"
With ActiveSheet
For i = LBound(arfiles, 2) To UBound(arfiles, 2)
If arfiles(0, i) = "" Then
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If
With .Cells(i + 1, arfiles(2, i))
.Value = arfiles(1, i)
.Font.Bold = True
End With
iStart = i + 1
iEnd = iStart
fOutline = False
Else
.Hyperlinks.Add Anchor:=.Cells(i + 1, arfiles(2, i)), _
Address:=arfiles(0, i), _
TextToDisplay:=arfiles(1, i)
iEnd = iEnd + 1
fOutline = True
End If
Next
.Columns("A:Z").ColumnWidth = 5
End With
End If
'just in case there is another set to group
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If

Columns("A:Z").ColumnWidth = 5
ActiveSheet.Outline.ShowLevels RowLevels:=1
ActiveWindow.DisplayGridlines = False

End Sub

'-----------------------------------------------------------------------
Sub SelectFiles(Optional sPath As String)
'-----------------------------------------------------------------------
Static FSO As Object
Dim oSubFolder As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim arPath

If FSO Is Nothing Then
Set FSO = CreateObject("Scripting.FileSystemObject")
End If

arPath = Split(sPath, "\")
cnt = cnt + 1
ReDim Preserve arfiles(2, cnt)
arfiles(0, cnt) = ""
arfiles(1, cnt) = arPath(level - 1)
arfiles(2, cnt) = level

Set oFolder = FSO.GetFolder(sPath)

level = level + 1
For Each oSubFolder In oFolder.Subfolders
SelectFiles oSubFolder.Path
Next
level = level - 1

End Sub

iscariot_0ne
05-14-2009, 12:15 PM
we're getting very close, if i replace the path: sFolder = "C:\test", with the path E:\Music\Music Which is my path i get back a list that looks like this. (the lower case "music" are actually indented)

Music
music
Music
Music
music
Music
music
music

So it looks to be reading the folders, but not populating the names??

if you want i could send you a screen shot if that would be more helpful

Bob Phillips
05-14-2009, 12:33 PM
w
So it looks to be reading the folders, but not populating the names??


I don't know what you mean by that.

iscariot_0ne
05-14-2009, 12:42 PM
it's like it names all the folders with the word "music" instead of the actual folder name.

so instead of being
David Bowie
-Best of David Bowie

it reads
Music
-music

maybe that helps?

Bob Phillips
05-14-2009, 12:50 PM
I don't see how it can do that, where would it get the text music from?

iscariot_0ne
05-14-2009, 01:13 PM
not sure, the only thing i changed was the path of C:\test to E:\music\music

ok, i just changed the path again to E:\Music instead of E:\music\music and it now kind of works, it listed the artist name for every folder, so if i have E:\music\music\David Bowie and there are 3 albums (each album is an individual folder) it will list the name David Bowie 3 times (like once for each album)... hopefully that makes sense

Bob Phillips
05-14-2009, 04:19 PM
Well it lists every folder, are you saying it shouldn't?

iscariot_0ne
05-15-2009, 05:12 AM
yes it should list every folder, but it's not listing them properly though, it's like it misses a layer of subfolders somewhere??? it doesn't go past the artist and into the albums

Kenneth Hobs
05-15-2009, 06:49 AM
I am a bit late to this. If you would attach an xls with a few entries in the format that you want, it would help us help you.

I saw the same thing with xld's code. No hyperlinks were created either. Something is amiss but I don't have time to look into it right now. FSO is certainly a valid method. I would use it or a DOS method most likely.

The indent part is the part that I would need to think about. It just takes a bit more work. Getting the subfolders and making hyperlinks is easy

I would recommend that you keep an open mind though. Many solutions are possible. While code may seem complicated, using a custom Sub or Function is usually quite easy. The hard part is designing the Sub or Function.

Bob Phillips
05-15-2009, 07:52 AM
I saw the same thing with xld's code. No hyperlinks were created either.

The original code hyperlinked to the files, but the OP said he only wanted folders, so I removed the files (ipso facto, the hyperlinks also).

Kenneth Hobs
05-15-2009, 10:24 AM
My DOS method is shown here. You will need the ExecCmd and SpeedUp modules or just use the attached xls. Modify the Test sub to fit your needs.
'IndentSubFolders() designed for, http://vbaexpress.com/forum/showthread.php?t=26699
'ExecCmd, 'Kenneth Hobson, http://www.vbaexpress.com/forum/showthread.php?t=25961
'Speedup module for SpeedOn, SpeedOff: http://vbaexpress.com/kb/getarticle.php?kb_id=1035
Sub Test_IndentSubFolders()
Dim MyParentFolder As String

MyParentFolder = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & _
Application.PathSeparator & "My Music"
'MyParentFolder = "c:\test"

IndentSubFolders MyParentFolder, Worksheets("Sheet2").Range("A2")

'AutoFit the column
Worksheets("Sheet2").Columns("A:A").EntireColumn.AutoFit
End Sub

Sub IndentSubFolders(parentFolder As String, firstCell As Range)
Dim a As Variant, v As Variant, r As Range
Dim oiLevel As Integer, iLevel As Integer, cl As String

'Exit if parentfolder does not exist
If Dir(parentFolder, vbDirectory) = "" Then
MsgBox "The parent folder does not exist. Macro is ending." & _
vbLf & parentFolder, vbError, "Error"
GoTo TheEnd
End If

On Error GoTo TheEnd
'http://vbaexpress.com/kb/getarticle.php?kb_id=1035
SpeedOn

'Strip trailing backslash if it exists in the parent folder
If Right(parentFolder, 1) = "\" Then parentFolder = Left(parentFolder, Len(parentFolder) - 1)

'Fill array a with subfolder names.
a = SubFolders(parentFolder)
'Exit sub if no subfolders found
If UBound(a) = -1 Then GoTo TheEnd

'Add subfolder as an indented hyperlink
Set r = firstCell
oiLevel = UBound(Split(parentFolder, "\"))
r.Clear
r.IndentLevel = 0
ActiveSheet.Hyperlinks.Add Anchor:=r, Address:= _
parentFolder, TextToDisplay:=Dir(parentFolder, vbDirectory)
Set r = r.Offset(1, 0)
For Each v In a
iLevel = UBound(Split(v, "\")) - oiLevel
r.Clear
r.IndentLevel = iLevel
ActiveSheet.Hyperlinks.Add Anchor:=r, Address:= _
v, TextToDisplay:=Dir(v, vbDirectory)
Set r = r.Offset(1, 0)
Next v

TheEnd:
SpeedOff
End Sub

'Similar to DOS file method in: http://www.vbaexpress.com/forum/showthread.php?t=22245
Function SubFolders(Folder As String) As Variant
Dim tFile As String
Dim hFile As Integer, str As String, vArray As Variant, e As Variant
Dim i As Long
Dim iHandle As Integer

'Delete temp file if it exists and create path
tFile = Environ$("temp") & "\SubFolders.txt"
'If Dir$(tFile) <> "" Then Kill tFile
'Write a 0 byte file
iHandle = FreeFile
Open tFile For Output Access Write As #iHandle
Close #iHandle

'Put files into tFile, http://support.microsoft.com/kb/q129796/
ExecCmd Environ$("comspec") & " /c Dir /ad/s/b " & """" & Folder & """" & " > " & tFile, vbHide

'Show tFile in Notepad
'Shell "Notepad " & tFile

'Put tFile contents into an array
hFile = FreeFile
Open tFile For Binary Access Read As #hFile
str = Input(LOF(hFile), hFile)
Close hFile
vArray = Split(str, vbCrLf)

'Add trailing path separators
'For i = 0 To UBound(vArray)
'If vArray(i) <> vbNullString Then vArray(i) = TrailSep(CStr(vArray(i)))
'Next i

Kill tFile
'Shell "notepad " & """" & tFile & """", vbNormalFocus

SubFolders = vArray
End Function


Function TrailSep(str As String) As String
If Right(str, 1) = Application.PathSeparator Then
TrailSep = str
Else: TrailSep = str & Application.PathSeparator
End If
End Function


Function AppSep(str As String) As String
If Left(str, 1) <> Application.PathSeparator Then str = Application.PathSeparator & str
If Right(str, 1) <> Application.PathSeparator Then str = str & Application.PathSeparator
AppSep = str
End Function