Visual Basic

FolderID   FolderName	FolderPath		
1	   19	        C:\Users\Name\Sample\19
1          20           C:\Users\Name\Sample\20
2          1            C:\Users\Name\Sample\20\1
2          2            C:\Users\Name\Sample\20\2
2          7            C:\Users\Name\Sample\20\7

Option Compare Database
Option Explicit
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const BIF_EDITBOX = &H10
Private Const BIF_NEWDIALOGSTYLE = &H40
Private Const MAX_PATH = 260
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Type BrowseInfo
    hWndOwner      As Long
    pIDLRoot       As Long
    pszDisplayName As Long
    lpszTitle      As Long
    ulFlags        As Long
    lpfnCallback   As Long
    lParam         As Long
    iImage         As Long
End Type
Dim BrowsePath As String

Private Sub CmdBrowse_Click()
On Error GoTo ErrorHandler
Dim lpIDList As Long, strTitle As String, tBrwInfo As BrowseInfo
26    strTitle = "Please select your media directory:"
27    With tBrwInfo
28        .hWndOwner = Me.hwnd
29        .lpszTitle = lstrcat(strTitle, "")
30        .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_EDITBOX + BIF_NEWDIALOGSTYLE
    End With
32    lpIDList = SHBrowseForFolder(tBrwInfo)
33    If (lpIDList) Then
34        BrowsePath = Space(MAX_PATH)
35        SHGetPathFromIDList lpIDList, BrowsePath
36        BrowsePath = Left(BrowsePath, InStr(BrowsePath, vbNullChar) - 1)
37        Me.txt_String = BrowsePath
    End If
ErrorExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error in CmdBrowse() " & vbCrLf & _
           "Number: " & Err.Number & vbCrLf & _
           "Description: " & Err.Description & vbCrLf & _
           "Line Number: " & Erl()
    Err.Clear
    Resume ErrorExit
End Sub

Private Sub CmdSearch_Click()
On Error GoTo ErrorHandler
Dim adoCON As New ADODB.Connection, adoRST As New ADODB.Recordset
53    'DoCmd.SetWarnings False
54    'DoCmd.RunSQL "Delete * FROM FoldersPath"
55    'DoCmd.SetWarnings True
56    Set adoCON = CurrentProject.Connection
57    adoRST.Open "SELECT * FROM FoldersPath", adoCON, adOpenKeyset, adLockOptimistic
58    SearchForFolders adoRST, BrowsePath, 1
59    adoRST.Close
60    Set adoRST = Nothing
ErrorExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error in CmdSearch() " & vbCrLf & _
           "Number: " & Err.Number & vbCrLf & _
           "Description: " & Err.Description & vbCrLf & _
           "Line Number: " & Erl()
    Err.Clear
    Resume ErrorExit
End Sub

Sub SearchForFolders(adoRST As ADODB.Recordset, strDIR As String, intCount As Integer)
On Error GoTo ErrorHandler
Dim objFSO As New FileSystemObject, fFolder As Folder, sFolder As Folder
75    Set fFolder = objFSO.GetFolder(strDIR)
76    For Each sFolder In fFolder.SubFolders
77        SearchForFolders adoRST, sFolder.Path, intCount + 1
78        With adoRST
79            .AddNew
80            !FolderID = intCount
81            !CreatedOn = Now()
82            !CreatedBy = Environ("UserName")
83            !FolderName = objFSO.GetFolder(sFolder).Name
84            !FolderPath = sFolder.Path
85            !FolderSize = objFSO.GetFolder(sFolder).Size
86            !DateCreated = objFSO.GetFolder(sFolder).DateCreated
87            !DateLastAccessed = objFSO.GetFolder(sFolder).DateLastAccessed
88            !DateLastModified = objFSO.GetFolder(sFolder).DateLastModified
89            .Update
        End With
    Next
ErrorExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error in SearchForFolder() " & vbCrLf & _
           "Number: " & Err.Number & vbCrLf & _
           "Description: " & Err.Description & vbCrLf & _
           "Line Number: " & Erl()
    Err.Clear
    Resume ErrorExit
End Sub

Memphis76 wrote:

The only problem I still have is that if in a folder I have more folders each
will have the same number

Sub SearchForFolders(adoRST as ADODB.Recordset, strDIR as Sring, ByRef intCount as Integer)
    '...
    intCount = intCount + 1
    SearchForFolders adoRst, sFolder.Path, intCount
    '...
End Sub

Memphis76 wrote:

I'm deleting all the records every time I run the SearchFolders() and the
auto-number kips incrementing otherwise)
I know this is done with the Do
Until i = 1 + (Last Folder Found)