Printable View
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.
ps i have been using dir() but the sub is getting confused and so am i..
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:
have fun!Code:'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
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
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/
see if this works for you, remember the reference to the microsoft scripting runtime.Code: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
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?
I don't know how to post a link to a thread, so here's the code:
You need a reference to Microsoft Scripting runtime, a command button, and a listbox.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
[Edited by jmcswain on 01-08-2001 at 06:11 PM]
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.
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!
ps i am now paying AU$3.50 ph connection now so i will be on infrequently :(
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
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.
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 ;)
what bulky ocx\dll?
Microsoft Scripting Runtime
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?
gerco:
Most of the code posted here, uses the FileSystemObject.
I'm telling you guys one more time!
USE MY CODE! :rolleyes:
no just kiddin', use whatever suites you, but in case you want it, here's my GetAllFiles function ;)
In a module:
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...Code:'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 \\\\---
Have fun with it.
Oh.. you call it like:
Code:'in a form
GetAllFiles("c:\", List1)
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:
Do you get the same results, or is my computer whacked?Code:FSO + DIR API
--------- --------
1st time running: 20 secs 26 secs
subsequents (cached): 5 secs 25 secs
so youve finally found a solution???
could you please post your FULL final peice of code please
Regards,
Simon
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?
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
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...
Declare
FunctionsCode:'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
Call FunctionCode: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
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.Code:Call FindFilesAPI(CStr(sPath), "*.mp3", NumFiles, "mp3search")
you can also change file type in the final working version these peeps found... it works for me so im sticking with it,
Chenko
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):
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.Code:SendMessage Listbox.hWnd, LB_ADDSTRING, 0&, ByVal strString
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
here's the stripnull function I grabbed from the Api-Guide
Code: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]
thanx jop, cut 4 seconds off a 12 second search! on a 13G drive :)
GREAT
Thanx again
and 2.4 seconds finding 167 songs on a 24spin uncached!
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
no worries, he said joe.. added to address book