VB6 - Enhance file listing, and cope with sub-dir's [resolved]

[thegreatone]

Hey everyone, well, i made this simple program to get all the files in a selected folder, and ten to search the 2nd level off folders in it, the porblem is most people will easily have more than two levels of folder to search within, how can i turn my example code into something that will deal with unlimited sub-dirs ?

My code :

Private Sub Form_Load()
    Dim strStartPath As String
    strStartPath = InputBox("Please enter start path", "Search Path", "C:\My Music")
    ListFolder strStartPath
End Sub
 
Private Sub ListFolder(sFolderpath As String)
    Dim FS As New FileSystemObject
    Dim FSfolder As Folder
    Dim subfolder As Folder
    Set FSfolder = FS.GetFolder(sFolderpath)
 
    For Each subfolder In FSfolder.SubFolders
        DoEvents
        Debug.Print subfolder
        List1.AddItem subfolder
    Next subfolder
    Set FSfolder = Nothing
LoopList
End Sub
 
Private Function ListSubFolder(sFolderpath As String)
    Dim FS As New FileSystemObject
    Dim FSfolder As Folder
    Dim subfolder As Folder
    Set FSfolder = FS.GetFolder(sFolderpath)
 
    For Each subfolder In FSfolder.SubFolders
        DoEvents
        Debug.Print subfolder
        List2.AddItem subfolder
    Next subfolder
    Set FSfolder = Nothing
End Function
 
Private Function LoopList()
List1.ListIndex = 0
Do Until List1.ListIndex = List1.ListCount - 1
    ListSubFolder List1.Text
    List1.ListIndex = List1.ListIndex + 1
    DoEvents
Loop
GetFiles
End Function
 
Private Function GetFiles()
List1.ListIndex = 0
List2.ListIndex = 0
Do Until List1.ListIndex = List1.ListCount - 1
    ListFiles List1.Text
    List1.ListIndex = List1.ListIndex + 1
DoEvents
Loop
Do Until List2.ListIndex = List2.ListCount - 1
    ListFiles List2.Text
    List2.ListIndex = List2.ListIndex + 1
DoEvents
Loop
End Function
 
Private Sub ListFiles(strPath As String, Optional Extention As String)
    Dim File As String
        If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"
        If Trim$(Extention) = "" Then
        Extention = "*.*"
    ElseIf Left$(Extention, 2) <> "*." Then
        Extention = "*." & Extention
    End If
        File = Dir$(strPath & Extention)
    Do While Len(File)
        List3.AddItem strPath & File
        File = Dir$
    Loop
End Sub
 
Private Sub List3_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
CD.Filter = "Winamp Playlist(*.M3U)|*.M3U"
CD.ShowSave
Open CD.FileName For Output As #1
For i = 0 To List3.ListCount - 1
Print #1, List3.List(i)
Next
Close #1
End Sub

I will attach my project also.

[sciguyryan]

Well, there is a much easier way if you are interested

Have a look at this

Cheers,

RyanJ

[thegreatone]

Well, there is a much easier way if you are interested

Have a look at this

Cheers,

RyanJ

Slight problem with that though, its for searching for a file in the Dir's and Sub dir's, i simply want to list the files...

Thanks for your input though.

[sciguyryan]

Slight problem with that though, its for searching for a file in the Dir's and Sub dir's, i simply want to list the files...

Thanks for your input though.

Oh, sorry...

How about one of these?

http://www.planet-source-code.com/vb...11311&lngWId=1
http://www.freevbcode.com/ShowCode.A...isting&ID=1331


Cheers,

RyanJ

[thegreatone]

Hey Thanks, i tried repping you for your endeavours but i simply get

You must spread some Reputation around before giving it to sciguyryan again.

EDIT: I thought i'd attach my code, and probably my project files for File Grabber.
EDIT2 : Mayeb this could be posted in the Codebank for future reference ?

Function FolderContents(ByRef thePath As String, ByRef bolRecurseDirectories As Boolean, ByRef scratchfile As String)
 
    Dim objFSO
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim objFolder
    Set objFolder = objFSO.getFolder(thePath)
    
    Call DisplayFolderContents(objFolder, bolRecurseDirectories, outFile)
    
 
    
 
    Set objFolder = Nothing
    Set objFSO = Nothing
End Function
 
 
Function DisplayFolderContents(objFolder, ByVal bolRecurseDirectories As Boolean, outFile)
 
    Dim objFile, strPath, strExtension
 
 
    For Each objFile In objFolder.Files
        strPath = objFile.Path
        List1.AddItem (objFile.Path)
    Next
 
    ' Recurse subdirectories if necessary
    Dim objSubFolder
 
 
    If bolRecurseDirectories Then
 
        For Each objSubFolder In objFolder.SubFolders
            DisplayFolderContents objSubFolder, bolRecurseDirectories, outFile
        Next
 
    End If
LblCount.Caption = List1.ListCount
End Function
 
Private Sub Command1_Click()
Dim x As String
Dim y As Boolean
If Option1.Value = True Then y = True
If Option2.Value = True Then y = False
x = InputBox("Please enter start path", "Search Path", "C:\My Music")
FolderContents x, y, ""
End Sub
 
Private Sub Command2_Click()
List1.Clear
End Sub
 
Private Sub Command3_Click()
On Error GoTo saveerr
f = FreeFile
CD.Filter = "Text Files (*.txt)|*.txt"
CD.ShowSave
Open CD.FileName For Output As #f
For i = 0 To List1.ListCount - 1
Print #f, List1.List(i)
Next
Close #f
Exit Sub
saveerr:
If Err.Number <> 75 Then MsgBox Err.Number & ":" & Err.Description, vbCritical, "An Error has occurred"
End Sub
 
Private Sub Command4_Click()
On Error GoTo saveerr
f = FreeFile
Dim x As String
x = InputBox("Which file extension do you wish to save as ?" & vbCrLf & "File extensions should look like this *.ext when entered below" & vbCrLf & "For example a playlist would be *.m3u", "Input File Extension", "*.txt")
CD.Filter = x & "|" & x
CD.ShowSave
Open CD.FileName For Output As #f
For i = 0 To List1.ListCount - 1
Print #f, List1.List(i)
Next
Close #f
Exit Sub
saveerr:
If Err.Number <> 75 Then MsgBox Err.Number & ":" & Err.Description, vbCritical, "An Error has occurred"
End Sub

[ikkeugh]

Hey Thanks, i tried repping you for your endeavours but i simply get



EDIT: I thought i'd attach my code, and probably my project files for File Grabber.
EDIT2 : Mayeb this could be posted in the Codebank for future reference ?

Function FolderContents(ByRef thePath As String, ByRef bolRecurseDirectories As Boolean, ByRef scratchfile As String)
 
    Dim objFSO
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim objFolder
    Set objFolder = objFSO.getFolder(thePath)
    
    Call DisplayFolderContents(objFolder, bolRecurseDirectories, outFile)
    
 
    
 
    Set objFolder = Nothing
    Set objFSO = Nothing
End Function
 
 
Function DisplayFolderContents(objFolder, ByVal bolRecurseDirectories As Boolean, outFile)
 
    Dim objFile, strPath, strExtension
 
 
    For Each objFile In objFolder.Files
        strPath = objFile.Path
        List1.AddItem (objFile.Path)
    Next
 
    ' Recurse subdirectories if necessary
    Dim objSubFolder
 
 
    If bolRecurseDirectories Then
 
        For Each objSubFolder In objFolder.SubFolders
            DisplayFolderContents objSubFolder, bolRecurseDirectories, outFile
        Next
 
    End If
LblCount.Caption = List1.ListCount
End Function
 
Private Sub Command1_Click()
Dim x As String
Dim y As Boolean
If Option1.Value = True Then y = True
If Option2.Value = True Then y = False
x = InputBox("Please enter start path", "Search Path", "C:\My Music")
FolderContents x, y, ""
End Sub
 
Private Sub Command2_Click()
List1.Clear
End Sub
 
Private Sub Command3_Click()
On Error GoTo saveerr
f = FreeFile
CD.Filter = "Text Files (*.txt)|*.txt"
CD.ShowSave
Open CD.FileName For Output As #f
For i = 0 To List1.ListCount - 1
Print #f, List1.List(i)
Next
Close #f
Exit Sub
saveerr:
If Err.Number <> 75 Then MsgBox Err.Number & ":" & Err.Description, vbCritical, "An Error has occurred"
End Sub
 
Private Sub Command4_Click()
On Error GoTo saveerr
f = FreeFile
Dim x As String
x = InputBox("Which file extension do you wish to save as ?" & vbCrLf & "File extensions should look like this *.ext when entered below" & vbCrLf & "For example a playlist would be *.m3u", "Input File Extension", "*.txt")
CD.Filter = x & "|" & x
CD.ShowSave
Open CD.FileName For Output As #f
For i = 0 To List1.ListCount - 1
Print #f, List1.List(i)
Next
Close #f
Exit Sub
saveerr:
If Err.Number <> 75 Then MsgBox Err.Number & ":" & Err.Description, vbCritical, "An Error has occurred"
End Sub

great code, however,how could you make it handle a greater map
e.g. "c:\"