Option Compare Database

Dim cn As Connection
Dim fo As Scripting.FileSystemObject
Dim rs As Recordset

Sub test()
Set fo = New FileSystemObject
Dim fl As Folder
Set fl = fo.GetFolder("c:\")
Debug.Print fl.Name, fl.Attributes, fl.Path
End Sub

Private Sub Connect()
Set cn = New Connection
cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Documents and Settings\Alex\Desktop\test1.mdb;Persist Security Info=False"
cn.CursorLocation = adUseClient
cn.Open
End Sub

Sub MakeInventory()
Connect
Set fo = New FileSystemObject
Set rs = New Recordset
rs.CursorType = adOpenDynamic
rs.LockType = adLockOptimistic
rs.Open "select * from filesystem", cn
'cn.Close
ProcessFolder fo.GetFolder("f:\"), 1
MsgBox "All Done"
End Sub

Sub ProcessFolder(f As Folder, parent As Long)
Static ix As Long
Dim DirID As Long
Dim fl As File
Dim fd As Folder
Dim a As FileAttribute
On Error Resume Next
Debug.Print ix,
Debug.Print "Folder: " & f.Name
rs.AddNew
rs!filename = f.Name
rs!ParentDirectory = parent
ix = ix + 1
DirID = ix
rs!RecID = ix
rs!Size = f.Size
rs!Created = f.DateCreated
rs!Modified = f.DateLastModified
rs!Accessed = f.DateLastAccessed
rs!Directory = f.Attributes And Directory
rs!ReadOnly = f.Attributes And ReadOnly
rs!Hidden = f.Attributes And Hidden
rs!System = f.Attributes And System
rs!Archive = f.Attributes And Archive
rs.Update

1: On Error GoTo errh

For Each fl In f.Files
2: On Error Resume Next
    ix = ix + 1
    rs.AddNew
    rs!RecID = ix
    rs!filename = fl.Name
    rs!ParentDirectory = DirID
    rs!Size = fl.Size
    rs!Created = fl.DateCreated
    rs!Modified = fl.DateLastModified
    rs!Accessed = fl.DateLastAccessed
    rs!Directory = fl.Attributes And Directory
    rs!ReadOnly = fl.Attributes And ReadOnly
    rs!Hidden = fl.Attributes And Hidden
    rs!System = fl.Attributes And System
    rs!Archive = fl.Attributes And Archive
    rs.Update
Next
TrySubfolders:
On Error GoTo errh
For Each fd In f.SubFolders
3: On Error Resume Next
    ProcessFolder fd, DirID
Next
Exit Sub
errh:
cn.Execute "insert into Errors values(" & ix & "," & Err.Number & ",'" & Err.Description & "')"
If Erl = 1 Then Resume TrySubfolders
End Sub

Public Function GetPath(id)
Dim rs As Recordset
Dim tmp As String
Dim parent As Long
If IsNull(id) Then Exit Function
If cn Is Nothing Then Connect
Set rs = New Recordset
With rs
    Set .ActiveConnection = cn
    .CursorLocation = adUseClient
    .CursorType = adOpenForwardOnly
    .LockType = adLockReadOnly
    .source = "Select RecID,FileName,ParentDirectory from edrive where RecID=" & id & " or (Directory=true and RecID<" & id & ") order by RecID desc"
    .Open
    tmp = !filename & ""
    parent = !ParentDirectory
    .MoveNext
    While Not .EOF
        If !RecID = parent Then
            tmp = !filename & "\" & tmp
            parent = !ParentDirectory
        End If
        .MoveNext
    Wend
End With
GetPath = tmp
End Function

Sub deletedups()
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("duplicates")
While Not rs.EOF
    On Error Resume Next
    SetAttr "e:" & rs!filename, vbNormal
    On Error GoTo 0
    Kill "e:" & rs!filename
    rs.MoveNext
Wend
End Sub

Sub DeleteEmptyFolders()
Dim f As Folder
Set fo = New Scripting.FileSystemObject
Set f = fo.GetFolder("e:\")
Debug.Print f.Files.Count, f.SubFolders.Count
DeleteEmptyDirs f
End Sub

Sub DeleteEmptyDirs(f As Folder)
Dim s As Folder
On Error GoTo Away
For Each s In f.SubFolders
    DeleteEmptyDirs s
    If s.Files.Count + s.SubFolders.Count = 0 Then
        Debug.Print s.Path
        s.Delete True
    End If
Next
Away:
End Sub