Excel Listing tool using VB

Hi Everyone.

We are currently doing an audit on all the Access databases in use in our
business and would like to send a list out of all the databases we can find
to their users to find out if they are still required. The problem we are
having is that the standard microsoft search tool doesn't seem to output the
list of files. In order to remedy this I found an excel tool a few years
back which will do this task for you.

The problem we then found was that the number of results between the
microsoft search and the excel file did not match. On investigation this
was found to be because the excel tool did not seem to be searching zip file
archives as the microsoft search was.

I have copied the code below incase anyone can see what we would need to
change in order to search zip files too.

Thanks in advance,

John

(P.S. I am happy to send the excel spread*** tool to anyone who requests
it)

__________________________________________________________________

Code follows:

--------------------------
Module: ListFiles2
--------------------------

Sub ListFiles2()
Dim LastStartPoint As String
Dim directories() As String, CurrentDirectory As String
Dim DirCounter As Integer, DirValue As String
Dim filelist As Variant

On Error GoTo 0

ShowHiddenAndSystemFiles = MsgBox("Show HIDDEN and SYSTEM files?",
vbYesNoCancel, "Hidden & system files")

' SelectedDir is a public variable set within the DisplayDirectoryDialogBox
sub.
If ShowHiddenAndSystemFiles = vbCancel Then Exit Sub
StartPoint = SelectedDir

' Add a *** to put the output on.
' It is labelled with the date and time so that it won't clash with other
*** names
UserForm2.LB_Directory.Caption = " Currently searching directory " &
SelectedDir
Sheets.Add after:=Worksheets(1)
Active***.Name = "Files " & Format(Now, "dd-mmm-yyyy hh-mm-ss AM/PM")
With Range("A1")
.FormulaR1C1 = "File Directory and Name"
.Offset(0, 1).Value = "File Size"
.Offset(0, 2).Value = "File Date & Time"
End With
Range("A:A").ColumnWidth = 40
Range("B:C").ColumnWidth = 15
Range("c:C").NumberFormat = "dd-mmm-yyyy hh:mm:ss AM/PM"
Range("c1").ColumnWidth = 25
Range("A2").Select
filelist = Range(ActiveCell, ActiveCell.End(xlDown).Offset(0, 2)).Value
ReDim directories(2)

' Add a backslah to the directory starting point if it was not entered.

If Right(StartPoint, 1) = "\" Then
directories(1) = StartPoint
Else
directories(1) = StartPoint & "\"
End If

directories(2) = ""

' initialise Directory counter

DirCounter = 1
FileCount = 0
On Error Resume Next

' Now loop through the directories() array.
' For each entry test whether it's a file or a directory.
' If it's a file then add it to the filelist() array.
' If it's a directory then add it to the directories() array.
' Keep going until there are no more entries in the directories array()!!

Do While directories(DirCounter) <> ""
CurrentDirectory = directories(DirCounter)

' use the DIR() function to get the first entry for the current directory

If ShowHiddenAndSystemFiles = vbYes Then
DirValue = Dir(CurrentDirectory, vbDirectory + vbHidden + vbSystem)
Else
DirValue = Dir(CurrentDirectory, vbDirectory)
End If

Do While DirValue <> ""

' write the file name sto the statusbar to show that something useful is
happening

Application.StatusBar = CurrentDirectory & DirValue

If InStr("..", DirValue) = 0 Then

' Use the GetAttr() function to check whether the entry is a directory.
' it's a directory entry so check to see if it's "." or ".."
' these are returned by the DIR() function but should be ignored

dirok = GetAttr(CurrentDirectory & DirValue) And vbDirectory
If dirok Then

' Add one more line to the Directories() array and
' paste the text into the array.

ReDim Preserve directories(UBound(directories) + 1)
directories(UBound(directories) - 1) = CurrentDirectory & DirValue & "\"
Else

' must be a file so store the file name and it's attributes

FileCount = FileCount + 1
filelist(FileCount, 1) = CurrentDirectory & DirValue
filelist(FileCount, 2) = FileLen(CurrentDirectory & DirValue)
'Format(Now, "dd-mmm-yyyy hh-mm-ss AM/PM")
filelist(FileCount, 3) = Format(FileDateTime(CurrentDirectory &
DirValue), "dd-mmm-yyyy hh:mm:ss AM/PM")
SumDiskSpace = SumDiskSpace + filelist(FileCount, 2)
UserForm2.LB_FileNumber.Caption = " Number of files found is " &
FileCount
UserForm2.LB_Space.Caption = " Disk space currently used is " &
Int(SumDiskSpace / 100000) / 10 & " MB"
Application.StatusBar = "Space so far is " & SumDiskSpace
If Int(FileCount / 10) * 10 = FileCount Then
UserForm2.Image1.Visible = Not UserForm2.Image1.Visible
UserForm2.Image2.Visible = Not UserForm2.Image1.Visible
End If
DoEvents
End If
End If

' get the next value fron the DIR() function

DirValue = Dir()
Loop
DirCounter = DirCounter + 1

Loop

Range(ActiveCell, ActiveCell.End(xlDown).Offset(0, 2)).Value = filelist
Application.StatusBar = False

End Sub


--------------
Module: 1
--------------

Option Explicit
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Public SelectedDir As String
Public StartPoint As String
Dim DirCounter As Integer
Dim currdir
Dim dirtopaste, dirok
Public SumDiskSpace As Double
Public FileCount As Integer

'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As
String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Sub DisplayDirectoryDialogBox()
Dim Msg As String
FileCount = 0
Msg = "Select a location containing the files you want to list."
SelectedDir = GetDirectory(Msg)
If SelectedDir = "" Then End
With Application
.StatusBar = "WAIT..."
.ScreenUpdating = False
End With
SumDiskSpace = 0
' listfiles is the original code
' MsgBox Application.Caller
If Application.Caller = "Files1" Then
Call listfiles
Else
' listfiles2 is modified using arrays to run faster in EXCEL97
' Call ListFiles2
UserForm2.Show
End If

With Application
.StatusBar = ""
.ScreenUpdating = True
End With
If FileCount = 0 Then
MsgBox "No files were returned."
Else
MsgBox "The list is complete. " & Chr(13) & Chr(10) & _
"Found " & FileCount & " files" & Chr(13) & Chr(10) & _
"Occupying " & Int(SumDiskSpace / 100000) / 10 & " MB"
End If
End Sub

Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer

' Root folder = Desktop
bInfo.pidlRoot = 0&

' Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else: bInfo.lpszTitle = Msg
End If

' Type of directory to return
bInfo.ulFlags = &H1

' Display the dialog
x = SHBrowseForFolder(bInfo)

' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else: GetDirectory = ""
End If
End Function

'Enter files into work***
Sub listfiles()
Dim c As Range

Active***.UsedRange.Clear
Set c = Range("A1")

On Error GoTo 0
StartPoint = SelectedDir

If Dir(StartPoint, vbDirectory + vbHidden + vbSystem) = "" Then
MsgBox "There are no entries in the directory " & StartPoint & "."
Exit Sub
End If

On Error GoTo errorproc
ReDim directs(2)

If Right(StartPoint, 1) = "\" Then
directs(1) = StartPoint
Else: directs(1) = StartPoint & "\"
End If

directs(2) = ""
DirCounter = 1
Do While directs(DirCounter) <> ""
currdir = directs(DirCounter)
'dirtopaste = Dir(currdir, vbDirectory + vbHidden + vbSystem)
'dirtopaste = Dir(currdir, vbDirectory)
dirtopaste = Dir(currdir, vbHidden)

Do While dirtopaste <> ""
dirok = True
If GetAttr(currdir & dirtopaste) = vbDirectory Then
' it's a directory so paste the text into the array
If dirok Then
If InStr("..", dirtopaste) = 0 Then
' ignore directories above the current position
ReDim Preserve directs(UBound(directs) + 1)
directs(UBound(directs) - 1) = currdir & dirtopaste &
"\"
End If
End If
Else ' must be a file

c.Value = currdir & dirtopaste
If c.Row = 16384 Then
Set c = Cells(1, c.Column + 1)
Else: Set c = c.Offset(1, 0)
End If
End If
'dirtopaste = Dir(, vbDirectory + vbHidden + vbSystem)
dirtopaste = Dir
Loop
DirCounter = DirCounter + 1
Loop
Exit Sub

errorproc: dirok = False
Resume Next
End Sub

'IGNORE THIS
Function CountDigits(s As String) As Integer

Dim i
For i = 1 To Len(s)
If Mid(s, i, 1) Like "\" Then
CountDigits = CountDigits + 1
End If
Next i

End Function

Sub Testlistfiles()
StartPoint = "c:\aslush\freds hidden secret stuff\"

If Dir(StartPoint, vbDirectory + vbHidden + vbSystem) = "" Then
MsgBox "There are no entries in the directory " & StartPoint & "."
Exit Sub
End If

' dirtopaste = Dir(StartPoint, vbHidden)
' dirtopaste = Dir(StartPoint, vbNormal)
dirtopaste = Dir(StartPoint, vbDirectory + vbHidden + vbSystem)
Do While dirtopaste <> ""
MsgBox dirtopaste
dirtopaste = Dir
Loop
Exit Sub
End Sub


.