finding all instances of *.mp3 on a drive

[steve(again)]

i am writting a little app that automatically catalogs my mp3s, i have got to the point where it is doing it as i select a file, but i want to be able to click a button and the app searches say drive d: for all files that are *.mp3 in any folder, whatever depth, stuck on this for 2 days now, any help greatly appreciated.

[steve(again)]

ps i have been using dir() but the sub is getting confused and so am i..

[Jop]

Use my File Module:
http://www.geocities.com/despotez/file.bas.txt

and use the GetAllFiles function.

Modify it so it searches for the extension .mp3:

'Replace this line
If dr = False And dts Then Lst.AddItem startdir & d 'add to list

'with this one
If dr = False And dts And Right(d, 4) = ".mp3" Then Lst.AddItem startdir & d 'add to list

have fun!

[steve(again)]

thanx jop, ive been busy, this is what ive managed myself, but sometimes it doubles up, other times it crashes..

Option Explicit
Private Type Class
strString As String * 100
End Type


Private Sub cmdExit_Click()
End
End Sub

Private Sub cmdProcess_Click()
On Error GoTo fine
Kill ("c:\windows\temp\zzMP3s.txt")
Kill ("c:\windows\temp\zzDIRs.txt")
fine:
Dim MyPath As String
Dim MyName As String
Dim objMP3file As Class
Dim objPath As Class
Dim fhMP3FNum As Integer
Dim fhDIRFNum As Integer
Dim strSlash As String * 1
strSlash = "\"

MyPath = "d:\"
Do While (Left(MyPath, 2) <> "XX")
MyPath = catStringLeft(MyPath)
MyName = Dir(MyPath, vbDirectory) 'get first entry in current directory
Do While MyName <> "" 'start the loop
If MyName <> "." And MyName <> ".." Then
If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
'DIRECTORY
objPath.strString = MyPath & MyName & strSlash
lblDir.Caption = objPath.strString
'FILE PROCESS
fhDIRFNum = FreeFile
Open "c:\windows\temp\zzDIRs.txt" For Random As fhDIRFNum Len = Len(objPath)
Put #fhDIRFNum, 1 + LOF(fhDIRFNum) / Len(objPath), objPath 'APPEND entry to end of DB
Close fhDIRFNum
Else
'FILE
If Right(MyName, 4) = ".mp3" Then
'MP3 FILE
lblMP3.Caption = MyName
fhMP3FNum = FreeFile
objMP3file.strString = MyPath & MyName 'if error chang to and
Open "c:\windows\temp\zzmp3s.txt" For Random As fhMP3FNum Len = Len(objMP3file)
Put #fhMP3FNum, 1 + LOF(fhMP3FNum) / Len(objMP3file), objMP3file 'APPEND entry to end of DB
Close fhMP3FNum
End If
End If
End If
MyName = Dir
Loop
MyPath = NextPath()
'If Left(MyPath, 2) <> "XX" Then GoTo again
Loop
End Sub

Private Function NextPath()
Dim objNewPath As Class
Dim objTemp As Class
Dim strPath As String
Dim fhDIRFNum As Integer
Dim intCount As Integer

fhDIRFNum = FreeFile
intCount = 1
objTemp.strString = "XX"

Open "c:\windows\temp\zzDIRs.txt" For Random As fhDIRFNum Len = Len(objNewPath)
Do While intCount < (LOF(fhDIRFNum) / Len(objNewPath))
Get #fhDIRFNum, intCount, objNewPath
If Left(objNewPath.strString, 2) = "XX" Then
'Path already used and removed
intCount = intCount + 1
Else
Put #fhDIRFNum, intCount, objTemp
intCount = LOF(fhDIRFNum) / Len(objNewPath)
End If
Loop
NextPath = objNewPath.strString
Close fhDIRFNum
End Function
Private Function catStringLeft(strTemp As String)
Dim intCount As Integer
intCount = Len(strTemp)
On Error GoTo NoSlash
Do While Mid(strTemp, intCount, 1) <> "\"
intCount = intCount - 1
Loop
catStringLeft = Left(strTemp, intCount)
NoSlash:
If intCount = 0 Then
catStringLeft = "No Slash"
End If
End Function

[Jop]

I see doing 2 different loops, you shouldn't.

Do While (Left(MyPath, 2) <> "XX")

Doesn't seem to good either...

As a general suggestion I think it's a good practice to indent code, it makes your code look better, and easier to review or debug.

Use my GetAllFiles function if you want, it's faster too

Here is an example of using API or the Dir function to list certain extension of files on a drive. Just change the code around to search the extension you wish and the drive you want:
http://www.vb-world.net/demos/findfiles/

[badgers]

Option Explicit

'input the drive letter in the text box
'need to add a reference to microsoft scripting runtime
'two list boxes(list1 and MP3list) and one file list box(file1)
'I set the list1 and file1 visible property to false
'MP3list needs to be visible....
'just enter c for the c drive. you can tweak user input how ever you want
Private Sub Command1_Click() 'PS add a command button..
Dim i As Long, j As Long, MP3Name As String 'use longs just incase you have a lot of files
List1.AddItem (Text2.Text & ":\") 'put the root in the list box
Call ShowFolderList(Text2.Text & ":\") 'listbox will contain all the sub directories
For i = 0 To List1.ListCount - 1
File1.Path = List1.List(i)
    For j = 0 To File1.ListCount - 1
        MP3Name = File1.List(j)
        If Right(MP3Name, 4) = ".mp3" Then MP3list.AddItem (MP3Name)
    Next j
Next i
MsgBox "done"
End Sub
Sub ShowFolderList(folderspec)
    Dim f1, fc, x As Integer, i As Integer, j() As String
    Dim fs As New Scripting.FileSystemObject
    Dim f As Folder
    Set f = fs.GetFolder(folderspec)
    Set fc = f.SubFolders
    On Error Resume Next 'you may not have read access on all directories(I dont)
    For Each f1 In fc
        i = i + 1
        DoEvents
    Next
    ReDim j(i)

    For Each f1 In fc
        x = x + 1
        j(x) = f1.Name & "\"
        List1.AddItem (folderspec & f1.Name)
        Text2.Text = f1.Name
        DoEvents
    Next
    For x = 1 To i
        Call ShowFolderList(folderspec & j(x))
    Next
    DoEvents
End Sub

see if this works for you, remember the reference to the microsoft scripting runtime.

[badgers]

matt have you tried that example you linked to.
It does not work for me. I am on NT.
anyone else using NT and VB6 SP4 get that example to work?

[jmcswain]

I don't know how to post a link to a thread, so here's the code:

Private Sub Command1_Click()
    List1.Clear
    Me.MousePointer = vbHourglass
    GetAllDirsFrom "c:"
    Me.MousePointer = vbNormal
End Sub
    
Private Function GetAllDirsFrom(ByVal pstrDir As String)
    Dim fso As FileSystemObject
    Dim fldrMain As Folder
    Dim fldrsSub As Folders
    Dim fldr As Folder
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fldrMain = fso.GetFolder(pstrDir & "\")
    If Right(fldrMain.Path, 1) = "\" Then
        AddAllFilesFrom Left(fldrMain.Path, Len(fldrMain.Path) - 1)
    Else
        AddAllFilesFrom fldrMain.Path
    End If
    ' Recurse subdirectories
    Set fldrsSub = fldrMain.SubFolders
    For Each fldr In fldrsSub
        GetAllDirsFrom fldr.Path
    Next
    DoEvents
End Function

Private Function AddAllFilesFrom(ByVal pstrDir As String)
    strFile = pstrDir & "\" & Dir(pstrDir & "\*.mp3")
    Do Until strFile = pstrDir & "\"
        List1.AddItem strFile
        strFile = pstrDir & "\" & Dir
    Loop
End Function

You need a reference to Microsoft Scripting runtime, a command button, and a listbox.

[Edited by jmcswain on 01-08-2001 at 06:11 PM]

[steve(again)]

High Jop, that was another question, wasnt sure if i should start a new thread though, how do you post listings so they are formatted? my code is indented, but when i copy and paste into 'your reply' all formatting and colour coding is lost. I have been trying further with my program and have solved the not reading last subdirectory by explicitly getting it to when it actually thinks its finished, but even before this code was added, when checking particularly my C:\ drive the program bomed out, even crashing VB, it seemed to have problems with startmenu folders, dll folders amongst(sp?) others, i believe there is a bug in VB that i cant work around, if you tell me how to paste text without loosing formatting i will post my current listing, in the mean-time i will look further into the suggestions posted.
Thank-you for your time and effort.
Steve.

[HeSaidJoe]

Code Formatting

[steve(again)]

how do i add a reference to microsoft scripting runtime?
is it causing the following problem (not referencing it?
Attribute VB_Name = "Module1" > compiler error - syntax error

Dim fso As FileSystemObject > user defined type not defined

when i used Matthew Gates link http://www.vb-world.net/demos/findfiles/
after i changed from *.* to *.mp3, both subroutines only checked the root directory
If optdir = True Then
findfilesdir lstdirs.List(0), "*.mp3"
Else
findfilesapi lstdirs.List(0), "*.mp3"
End If
changing it back went through the subdirectories
does dir$ do anything that dir cant do? is it superseeded?

i am on the net at odd times at the moment 5am here at the moment! cant sleep too hot 30 degrees c! if i am awake ill try and see if any of you could help.
hitting the sack for an hour before i go to work!

[steve(again)]

ps i am now paying AU$3.50 ph connection now so i will be on infrequently

[badgers]

go to the project pulldown menu
select references
in the pop up window titled References - Poject1
page down until you see microsoft scripting runtime
select the box and then click OK

[jmcswain]

To enable scripting, from the Project Menu select References, then check "Microsoft Scripting Runtime". (I think they are listed alphabetically.)

If that doesn't work, change all the variable types it doesn't recognize to Variants, and give it a shot.

I have some code lying around that does the job and returns a StringVector (java people wil know what that is) containing all filenames...

All you need is my StringVector class, of my Vector class (ObjectVector), and a small segment of code to search all files.

I cannot post it now, so e-mail me if you want it: [email protected]

Gerco Dries.

[Jop]

People, why adding *another* ocx if it isn't needed?
Use api (fast) or even Dir (slow) for this task, it may be a bit hard to understand, but at least it saves you a bulky OCX/DLL!

Hey Gerco, nog een nederlander hier

[badgers]

what bulky ocx\dll?

[Jop]

Microsoft Scripting Runtime

[jmcswain]

It's either API or Scripting Runtime. Interestingly, Dir is not capable of this task without vast amounts of extra effort due to the fact that its queue is global. If you call Dir() recursively, the new function's Dir() queue will blow away the parent function's Dir() queue. That why I use file scripting. (Well, I'm lazy, so I do a mix because Dir() is so easy to code with.)

Since when do you need that?

[Jop]

gerco:
Most of the code posted here, uses the FileSystemObject.

I'm telling you guys one more time!

USE MY CODE!

no just kiddin', use whatever suites you, but in case you want it, here's my GetAllFiles function

In a module:

'Getallfiles
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Public Declare Function SetFileAttributes Lib "kernel32.dll" Alias "SetFileAttributesA" (ByVal lpFileName As String, ByVal dwFileAttributes As Long) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long


'GetAllFiles
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type

'GetAllFiles
Private Const MAX_PATH = 260
Private Const MAXDWORD = &HFFFF
Public Const FILE_ATTRIBUTE_DIRECTORY = &H10
Public Const FILE_ATTRIBUTE_HIDDEN = &H2
Public Const FILE_ATTRIBUTE_ARCHIVE = &H20
Public Const FILE_ATTRIBUTE_COMPRESSED = &H800
Public Const FILE_ATTRIBUTE_NORMAL = &H80
Public Const FILE_ATTRIBUTE_READONLY = &H1
Public Const FILE_ATTRIBUTE_SYSTEM = &H4
Public Const FILE_ATTRIBUTE_TEMPORARY = &H100

' ----////  GetAllFiles \\\\----
Public Sub GetAllFiles(startdir As String, Lst As ListBox)
Dim d$, dr As Boolean, dts As Boolean, dirs() As String
Dim FindData As WIN32_FIND_DATA, c%, File&
If Right(startdir, 1) <> "\" Then startdir = startdir & "\"
    
ReDim dirs(0)
File = FindFirstFile(startdir & "*", FindData)
c = 1

Do While c

   c = FindNextFile(File, FindData)
    d = StripNulls(FindData.cFileName)
dts = d <> "." And d <> ".." And Len(d) > 0
    If dts Then dr = (GetFileAttributes(startdir & d) And FILE_ATTRIBUTE_DIRECTORY)

        If dr = False And dts And Right(d, 4) = ".mp3" Then Lst.AddItem startdir & d 'add to list

            
            If dr And dts Then
                ReDim Preserve dirs(UBound(dirs) + 1)
                dirs(UBound(dirs)) = d
            End If
            
Loop

Dim x&
FindClose File
For x = 1 To UBound(dirs)
    GetAllFiles startdir & dirs(x), Lst
Next x
End Sub

Private Function StripNulls(OriginalStr As String) As String
'Got this from the API-Guide ( http://www.allapi.net )
    If (InStr(OriginalStr, Chr(0)) > 0) Then OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
    StripNulls = OriginalStr
End Function
'---//// End GetAllFiles \\\\---

I know it's not my best coding, I know I shouldn't add it to a listbox, for speed performance, but I'm lazy now...

Have fun with it.

Oh.. you call it like:

'in a form
GetAllFiles("c:\", List1)

[jmcswain]

Yep, it works nice. It's a touch processor intensive, though. Create a project with 1 listbox and 2 command buttons. Have the first command button call your function, and the second one call mine. (By the way: change the List1.Refresh do a DoEvents...it kills the flicker. Never mind, I just edited it.)

Both are writing to a listbox in the loop, so neither are going to be very fast. Searching for *.mdb on my hard drive using both functions, the results were:

                       FSO + DIR       API
                       ---------    --------
1st time running:       20 secs      26 secs
subsequents (cached):    5 secs      25 secs

Do you get the same results, or is my computer whacked?

so youve finally found a solution???
could you please post your FULL final peice of code please

Regards,
Simon

[jmcswain]

I did a while ago. It's the 9th post in this thread. Doesn't it work for you?

i avnt tried it yet... what controls do i add?

[jmcswain]

Add a command button and a listbox to a form, and copy the code from my post up above to the form's module. Then, from the Project Menu, select References, check Microsoft Scripting Runtime, and you should be all set.

works amazing and not that slow for a 20Gb harddrive!!! 1 problem i had to take the functions out of the module as it didnt work... ne way thanks and praise to the author of the code (post 9 or somit like dat)

Thanks and regards,
Simon

[jmcswain]

Glad it worked. Hehheh, I don't communicate well; when I said "copy the code to the Form's module" I actually meant copy the code into the form, not a module. Glad you figured it out. It's kind of unsettling how much faster it is the second time you run it...

[Berthil]

Declare

'list directories and files
Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Public Const MAX_PATH = 260
Public Const MAXDWORD = &HFFFF
Public Const INVALID_HANDLE_VALUE = -1
Public Const FILE_ATTRIBUTE_ARCHIVE = &H20
Public Const FILE_ATTRIBUTE_DIRECTORY = &H10
Public Const FILE_ATTRIBUTE_HIDDEN = &H2
Public Const FILE_ATTRIBUTE_NORMAL = &H80
Public Const FILE_ATTRIBUTE_READONLY = &H1
Public Const FILE_ATTRIBUTE_SYSTEM = &H4
Public Const FILE_ATTRIBUTE_TEMPORARY = &H100
Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type

Type WIN32_FIND_DATA
  dwFileAttributes As Long
  ftCreationTime As FILETIME
  ftLastAccessTime As FILETIME
  ftLastWriteTime As FILETIME
  nFileSizeHigh As Long
  nFileSizeLow As Long
  dwReserved0 As Long
  dwReserved1 As Long
  cFileName As String * MAX_PATH
  cAlternate As String * 14
End Type

Functions

Public Function StripNulls(OriginalStr As String) As String
    If (InStr(OriginalStr, Chr(0)) > 0) Then
        OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
    End If
    StripNulls = OriginalStr
End Function

Public Function FindFilesAPI(Path As String, SearchStr As String, FileCount As Integer, DirCount As Integer, sContext As String)
    Dim FileName As String   ' Walking filename variable...
    Dim DirName As String    ' SubDirectory Name
    Dim nDir As Integer   ' Number of directories in this path
    Dim i As Integer      ' For-loop counter...
    Dim hSearch As Long   ' Search Handle
    Dim WFD As WIN32_FIND_DATA
    Dim Cont As Integer
    Dim dirNames() As String ' Buffer for directory name entries
    Dim NodeKey As String
    
    If Right(Path, 1) <> "\" Then Path = Path & "\"
    ' Search for subdirectories.
    nDir = 0
    ReDim dirNames(nDir)
    Cont = True
    hSearch = FindFirstFile(Path & "*", WFD)
    If hSearch <> INVALID_HANDLE_VALUE Then
       Do While Cont
          DirName = StripNulls(WFD.cFileName)
          ' Ignore the current and encompassing directories.
          If (DirName <> ".") And (DirName <> "..") Then
          DoEvents
          If bAbort = True Then Exit Function
             ' Check for directory with bitwise comparison.
             If GetFileAttributes(Path & DirName) And FILE_ATTRIBUTE_DIRECTORY Then
                dirNames(nDir) = DirName
                DirCount = DirCount + 1
                nDir = nDir + 1
                ReDim Preserve dirNames(nDir)
                DoEvents
             End If
          End If
          Cont = FindNextFile(hSearch, WFD)  ' Get next subdirectory.
       Loop
       Cont = FindClose(hSearch)
    End If
    
    ' Walk through this directory and sum file sizes.
    hSearch = FindFirstFile(Path & SearchStr, WFD)
    Cont = True
    If hSearch <> INVALID_HANDLE_VALUE Then
       While Cont
          FileName = StripNulls(WFD.cFileName)
          If (FileName <> ".") And (FileName <> "..") Then
             FindFilesAPI = FindFilesAPI + (WFD.nFileSizeHigh * MAXDWORD) + WFD.nFileSizeLow
             FileCount = FileCount + 1
             'mp3 adding code here
             If bAbort = True Then Exit Function
          End If
          Cont = FindNextFile(hSearch, WFD)  ' Get next file
       Wend
       Cont = FindClose(hSearch)
    End If
    
    'If there are sub-directories and subdirectories is enabled
    If nDir > 0 Then
       ' Recursively walk into them...
        For i = 0 To nDir - 1
            DoEvents
            pnlMessage.Text = "Searching in " & Path
            FindFilesAPI = FindFilesAPI + FindFilesAPI(Path & dirNames(i) & "\", SearchStr, FileCount, DirCount, sContext)
            If bAbort = True Then Exit Function
        Next i
    End If
    Exit Function
End Function

Call Function

Call FindFilesAPI(CStr(sPath), "*.mp3", NumFiles, "mp3search")

I've added context to re-use the function for different purposes, but you can ommit that. Also ignore the bAbort although it gives a possibility to stop searching.

you can also change file type in the final working version these peeps found... it works for me so im sticking with it,

Chenko

[Kaverin]

Whenever I have to implement this type of search routine, I always resort to the API way as a couple people have already mentioned. Especially for huge drives like the ones available now, your grandchildren will graduate from college by the time dir() finishes . I also add something extra to them though. If you're going to be adding each one to a list or combo box, you should avoid .additem as well because it will compound the creepiness. I use the API SendMessage and LB_ADDSTRING (or CB_ADDSTRING):

   SendMessage Listbox.hWnd, LB_ADDSTRING, 0&, ByVal strString

Make sure you don't leave off the ByVal in front of the string to add since the 4th param of SendMessage is declared as Any. This will improve the speed of filling the listbox/combobox.

[steve(again)]

hi gang i think i have it sussed
but you MUST check for UPPERCASE, something like this, i have 3 songs that have ucase extensions and they wern't picked up.
If LCase(Right(strFile, 4)) = ".mp3" Then 'this also checks for *.MP3

i now need an ultra efficient way of loosing trailing NULLS, i am using lists (its what i settled on and seems to work) and API, but a new call to FindData.cFileName, TRIM$ does not do the job, this is how i have done it but i know it is slooow.

Public Function TrimNulls(strTemp As String)
Dim bytCVal As Byte
Dim intPosition As Integer

intPosition = 1
bytCVal = 1 'ie not 0
Do While bytCVal <> 0
intPosition = intPosition + 1
bytCVal = Asc(Mid(strTemp, intPosition, 1))
Loop
TrimNulls = Left(strTemp, intPosition - 1)
End Function

i hope you get this indented okay, just no colour/color
i have learnt a lot from your suggestions and sample programs/listings.
laters, Steve

ps should i start a new thread with the above question?
sorry it wasnt indented in the preview, huh

[Jop]

here's the stripnull function I grabbed from the Api-Guide

Private Function StripNulls(OriginalStr As String) As String
'Got this from the API-Guide ( http://www.allapi.net )
    If (InStr(OriginalStr, Chr(0)) > 0) Then OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
    StripNulls = OriginalStr
End Function

the code posted by jmcswain also works with either upper or lower case names...


#~#~##~#~#
#~Chenko~#
#~#~##~#~#
[email protected]

[steve(again)]

thanx jop, cut 4 seconds off a 12 second search! on a 13G drive
GREAT
Thanx again

[steve(again)]

and 2.4 seconds finding 167 songs on a 24spin uncached!

[HeSaidJoe]

If you add this line under your Option Explicit line you don't need to check for upper or lower case as the function just compares text regardless of case.

Option Explicit
Option Compare Text

PS...when you have all the wrinkels out, if you don't mind I would like to have a copy of the final code. If you would post the final or email it to me that would be great.

Thanks,
Wayne

[steve(again)]

no worries, he said joe.. added to address book