PDA

View Full Version : FileSearch



mdmackillop
02-19-2011, 10:32 AM
Finally got around to creating my own version. (Thanks to Bob and Ken whose code i pinched.)
It's a little bit messy, so any suggestions to tidy it up?

Option Explicit
Option Compare Text

Dim i As Long
Dim LookingFor As String
Dim FileSearch()


Sub DoFileSearch()
Dim FSO As Object
Dim Pth As String
Dim X As Long

'Set options
Pth = BrowseForFolder()

'Pth = BrowseForFolder(MyDocuments)
'Pth = BrowseForFolder("C:\") 'Processing C:\ can take a long time


LookingFor = "" 'Process filter if required
i = 0 'Counter if required
Cells.Clear 'Clear old results if required

ReDim FileSearch(6, 1000000)

Set FSO = CreateObject("Scripting.FileSystemobject")
Call ProcessFolder(FSO, Pth, True)
If i = 0 Then
MsgBox "No files found"
Exit Sub
Else
ReDim Preserve FileSearch(6, i - 1)
End If

'Process found files
Cells(1, 1).Resize(, 7) = Array("Path", "FileName", "Last Accessed", "Last Modified", "Created", "Type", "Size")
Cells(2, 1).Resize(i, 7) = Application.Transpose(FileSearch)

Set FSO = Nothing
End Sub

Private Function ProcessFolder( _
ByRef FSO As Object, _
ByVal Foldername As String, _
Optional ByVal Init As Boolean)

Dim Fldr As Object
Dim SubFldr As Object
Dim File As Object

Set Fldr = FSO.GetFolder(Foldername)

'Process head folder once only
If Init = True Then
For Each File In Fldr.Files
ProcessFiles Fldr, File
Next File
End If

On Error Resume Next
For Each SubFldr In Fldr.SubFolders
'Handle restricted folders e.g Recylce Bin
If Not Err = 70 Then
For Each File In SubFldr.Files
ProcessFiles SubFldr, File
Next File
Call ProcessFolder(FSO, SubFldr.Path)
End If
Next SubFldr

Set File = Nothing
Set SubFldr = Nothing
Set Fldr = Nothing
End Function

'Add files to array
Sub ProcessFiles(Fld, f)
If f.Name Like "*" & LookingFor Then
FileSearch(0, i) = Fld.Path
FileSearch(1, i) = f.Name
FileSearch(2, i) = f.DateLastAccessed
FileSearch(3, i) = f.DateLastModified
FileSearch(4, i) = f.DateCreated
FileSearch(5, i) = f.Type
FileSearch(6, i) = f.Size

i = i + 1
End If
End Sub

Function MyDocuments() As String
Dim wshShell As Object
Set wshShell = CreateObject("WScript.Shell")
MyDocuments = wshShell.Specialfolders("MyDocuments")
Set wshShell = Nothing
End Function

Function BrowseForFolder(Optional OpenAt As Variant) As Variant

'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level

Dim ShellApp As Object

'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0

'Destroy the Shell Application
Set ShellApp = Nothing

'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select

Exit Function

Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function

Bob Phillips
02-19-2011, 12:21 PM
Not much you can do as I see it Malcolm, it all needs to be done.

Personally, I would put it in a class, and see all the attributes as properties, such as Init etc.

One question, why are you dropping the results into the worksheet in a loop, why not just dump the array on the range?

mdmackillop
02-19-2011, 01:00 PM
Hi Bob,
I'll have a look at a Class. The output was just a simple example of looping the return.

Zack Barresse
02-19-2011, 04:42 PM
Were you thinking of coding some sort of browse for folder into it, as opposed to just My Documents? I agree about the class. It would allow more flexibility as to refine your search, perhaps by not only folder, but name, size, attributes, etc. Dunno, just thoughts.

mdmackillop
02-19-2011, 06:03 PM
Good idea with the browser Zack. I'll add that in. Re the Class, I've never made use of them, so I'm doing some reading!

Kenneth Hobs
02-19-2011, 06:30 PM
I posted a class example in: http://www.vbaexpress.com/forum/showthread.php?t=27144

mdmackillop
02-19-2011, 06:57 PM
Thanks Kenneth,
I'll check it out tomorrow.
I've reposted the code above with Ken's Browse routine and retrieved a bit more file data.

Bob Phillips
02-20-2011, 03:24 AM
I disagree about the browser, or at least insofar as it is in the class. To my way of thinking, the class should be passed an initial folder, and work on that. If you want to browse that should be outside of the class routine.

Zack Barresse
02-20-2011, 09:24 AM
Oh I would definitely make it outside the class, but I would still have that functionality. To me, if I were to use it, that would be one of my main desires. That and the functionality to refine my search in various ways. But I'm a user who loves options. :)

Bob Phillips
02-20-2011, 09:40 AM
Can't argue with that.

mdmackillop
02-20-2011, 10:34 AM
Latest (in progress) version which includes the original Sub verion along with my attempts at a Class (Thanks for the links Ken. Very instrucrive). For some reason the code "sticks" at different points for no apparent reasons.
Advice gratefully received.

The Browser code is used outwith the Class.

Kenneth Hobs
02-20-2011, 10:46 AM
When browsing for folder, I use Application.FileDialog. e.g. http://www.vbaexpress.com/forum/showthread.php?t=24307

Zack Barresse
02-20-2011, 10:48 AM
Bombs when cancel is pressed.

Set fldr = FSO.GetFolder(Foldername)

When "Foldername" returns "False".

mdmackillop
02-20-2011, 11:07 AM
Hi Zack,
There are still a few bugs and things such as excluding System Folders I want to add, but I was stuck with the progress freezing.

GTO
02-21-2011, 08:28 AM
...For some reason the code "sticks" at different points for no apparent reasons. Advice gratefully received...


Hi Zack,
There are still a few bugs and things such as excluding System Folders I want to add, but I was stuck with the progress freezing.

Hi Malcom, :hi:

I am not sure we experienced the same thing, but it seemed that it would get "stuck" on a file for a bit and sometimes get going again, but sometimes just hang (but not properly break, if that makes sense). Anyways, a bit frustrating, as it seemed tough to get it to break and see where it was stuck.

I think I found it :-)

'Add files to array
Sub ProcessFiles(Fld, f)
If f.Name Like "*" & LookingFor Then
i = i + 1
FileSearch(1, i) = CStr(Fld.path)
FileSearch(2, i) = CStr(f.Name)
FileSearch(3, i) = CStr(f.DateLastAccessed)
FileSearch(4, i) = CStr(f.DateLastModified)
FileSearch(5, i) = CStr(f.DateCreated)
FileSearch(6, i) = CStr(f.Type)
FileSearch(7, i) = CStr(f.Size)
'DoEvents
Application.StatusBar = i & "-" & Fld.path & "\" & f.Name
End If
End Sub

After 're-discovering' this, I recall that with the array being variant, it will try and sub-type the accessed/modified/created vals into dates. But every so often, the "Date/Time" will 'look' like a valid one, but the year will be some bizarre year like 1603 etc... Naturally it falls down.

Anyways, I also changed FileSearch to a String, propbably not necessary but I think no harm. Since I was trying different stuff, I also changed it to a 1-based array, as you see I jump i's value before rather than after.

Well, I hope that helps a little at least,

Mark

mdmackillop
02-21-2011, 12:21 PM
Hi Mark,
I had noticed issues with the dates and have tried CSTR etc. to change so simple strings. No improvement.
I finally tried commenting out all the FileSearch(1,i) etc. lines, leaving an empty array. The code still "sticks" however.

GTO
02-22-2011, 01:29 AM
Good Morning Malcom,

When you say "sticks", is it like my description? If just momentarily on certain files, are we talking about just where it is perceptible, or for several seconds or longer, or... does it actually hang?

I pm'd you

Mark

mdmackillop
02-22-2011, 10:45 AM
Hi Mark,
On a restricted listing, such as MyDocuments, the statusbar stops but the code carries on and finally completes. If I search the full C:, it fails but becuse of the "sticking" number, I can't determine where!

Tommy
02-22-2011, 11:17 AM
Hi Malcom,

The hangs are the FSO system changing directories. But this is my opinion which is subject to change at any second for no apparent reason. :)

Zack Barresse
02-22-2011, 12:09 PM
But this is my opinion which is subject to change at any second for no apparent reason. :)
Like :p

mdmackillop
02-22-2011, 02:48 PM
This is a 2003 version of the code, to which I've added a short time delay in each loop to allow for Tommy's suggestion. This avoids the hanging which was occurring. Next issue is that assigning to a variant (a) fails with larger data.
The same code still fails in 2010 however.

Tommy
02-23-2011, 03:56 PM
Malcom,

I made some modifications to your code. I have tested to 30,000 I will test on 2010 later tonight. In 2003 I am concerned about exceeding the 65,000 max range in excel it will go BOOM!

mdmackillop
02-23-2011, 04:48 PM
Hi Tommy, I'll have a look at your post tomorrow.

Some reading shows that transpose did not work with large arrays in previous versions of excel, 2000, 2003. I've not found yet a 2010 limit, but avoided this by using a coded transpose. This returns 118k files on my C drive.
When running on the C drive, the Statusbar hangs at 1800 or so. Running on MyDocuments, it shows all up to the 7500 files there. This was for debug only, but does seem a bit strange.

Public Function DoFileSearch() As Variant
Dim FSO As Object
Dim Pth As String
Dim x As Variant
Dim LookingFor As String
Dim Result()
Dim a As Long, b As Long

Pth = pLookIn
LookingFor = fileName
ReDim FileSearch(6, 1000000)

Set FSO = CreateObject("Scripting.FileSystemobject")
Call ProcessFolder(FSO, Pth, True)
If i = 0 Then
MsgBox "No files found"
Exit Function
Else
ReDim Preserve FileSearch(6, i - 1)
ReDim Result(i - 1, 6)
End If

'Process found files
On Error Resume Next



For a = 0 To 6
For b = 0 To i - 1
Result(b, a) = FileSearch(a, b)
Next b
Next a
DoFileSearch = Result()


Set FSO = Nothing
End Function

GTO
02-24-2011, 12:53 PM
Hi Malcom,

My apologies for former observations, as I was testing the Standard Module's code in the version at post #11. I do believe some observations remain the same when testing the Class version posted at #21.

I cannot find anywhere (I may well be apologizing again if I am missing more 'stuff') where the function MyDocuments() is called. Yet, every so often it is called. I rem'd it for the moment.

I ran C:\ at work. About 45,500 files.

If I click the button, pick C:\ and leave the cursor/mouse alone, it runs to completion in about 76 seconds. The statusbar 'sticks' on random files every so often, but only momentarily and will start repainting after every time it 'sticks' or 'catches'.

Alternatively, if I move the cursor down over the taskbar and over anything that would pop-up (for my sudden lack of better expression) the little control tip text, the status bar 'sticks' and stays stuck. If I wait a moment and break (ctrl + break), I note that the statusbar updates to whatever point the code is actually at. If I continue (VBIDE reduced so I can see the statusbar), statusbar is now updating.

If I substitute a DoEvents for the Application.Wait, I can pick other stuff, activate other apps, and statusbar keeps updating. It still occasionally 'sticks' for just long enough for your eyes to catch it, but these seem less often and shorter. Oh, and the DoEvents doesn't slow the code down (which I thought it would maybe), as it still ran in about 76 seconds.

Uhmmm, the one observed downside is that with the DoEvents, you can actually press the button again while the code is running. Excel doesn't think that this is very funny at all. (Nothing horrid, just makes the running code go 'thunk')

I also tried against my flashdrive (pen drive). While doing this, it seemed to me that the repaints/sticking issue was a little more pronounced. (DoEvents still in effect) Being a flashdrive of course it read slower, so 309 seconds for 15,500+ files. Still, status bar ran pretty good.

To get the kind of number of files you ran against, I made one try on a network drive. Yikes! We are on the oldest hub (something about the smoke signals should have tipped me off) and this was just too slow to run.

I am afraid I have run the code a good couple of dozen times, and I cannot replicate where you said it would actually stop running.

I ran out of time and was unable to test the updated code at #23.

Above observations were in 2003.

WEll, I have to sign-out. A great weekend to all (I get a long one)

Mark

mdmackillop
02-24-2011, 01:27 PM
Thanks for the hard work.
MyDocuments() was just used as an alternative start location. I never thought of DoEvents instead of the Delay. Good idea.
I think I understand now with the Transpose limit what was causing the fail. It was the partial success which was confusing. I'll discard the Status Bar code. It's not needed and was just to help isolate the error.

Tommy
02-24-2011, 02:27 PM
It still fails when you exceed 65535 files. It keeps running on the version I posted it just doesn't update excel. LOL Yes I do have that many files on my local PC.

One other note that is just bongleing my brain cells that are left. I kept getting a connection to Live ID failed due to not having a Live Id. I do have one but I tell it not to remember me. I am wondering what I was stepping on to get that?