Create hyperlinked top level folder names and append new folders to existing list

[pnvekaria]

I have an Excel code that I want to adapt and use with Access 2007.

The idea is to build a list of hyperlinked folders of top level directory and eventually keep updating the table with newly added folders (Basically I want it to compare and append new folders to an existing table list without overwriting any existing folder names).

I have attached a Sample of the excel file that I use currently and looking to move it to Access.

I am new to VBA and require some guidance to get the code working with Access?

Excel VBA code:
Sub DirTreeTopLevelOnly()
Dim Clear As Worksheet
Dim FSO As Scripting.FileSystemObject
Dim StartFolder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim R As Range
Dim FullPaths As VbMsgBoxResult
Dim ShowFiles As VbMsgBoxResult
Dim ShowFileDetails As VbMsgBoxResult
Dim HyperlinkFiles As VbMsgBoxResult
Dim HyperlinkFolders As VbMsgBoxResult
Dim Tidy As Worksheet
Dim F As Scripting.File
On Error Resume Next
Set Clear = Application.Worksheets("ListUpdate")
Worksheets("ListUpdate").Range("A2:A500").ClearContents
'ActiveSheet.ListObjects("Table9").Range.AutoFilterMode = False
'Application.ScreenUpdating = True

Range("B2").Select
ActiveCell.FormulaR1C1 = _
"=IF((ISNA(MATCH(RC[-1],Table13[Schemes],FALSE))),""New"","""")"
ActiveSheet.ListObjects("Table9").Range.AutoFilter Field:=2, Criteria1:= _
"New"
'Application.ScreenUpdating = True

If Err.Number <> 0 Then
MsgBox "ListUpdate tab does not exist. May have been moved or deleted", vbOKOnly
Exit Sub
End If
Set FSO = New Scripting.FileSystemObject
Err.Clear
Set StartFolder = FSO.GetFolder("c:\TestData")
If Err.Number <> 0 Then
MsgBox "No folder selected or specified folder does not exist.", vbOKOnly
Exit Sub
End If
On Error GoTo 0
FullPaths = vbNo
ShowFiles = vbNo
ShowFileDetails = vbNo
HyperlinkFiles = vbNo
HyperlinkFolders = vbYes

Set R = Range("A1")
R = StartFolder.Name
'If HyperlinkFolders = vbYes Then
'R.Hyperlinks.Add R, "file://" & StartFolder.Path, , StartFolder.Name, StartFolder.Name
'End If
Set R = R(2, 1)
If ShowFiles = vbYes Then
For Each F In StartFolder.Files
R(1, 2) = F.Name
If HyperlinkFiles = vbYes Then
R.Hyperlinks.Add R(1, 2), "file://" & F.Path, , F.Name, F.Name
End If
If ShowFileDetails = vbYes Then
R(1, 3).Value = F.Size
R(1, 4).Value = Format(F.DateLastModified, "dd-mmm-yyyy")
End If
Set R = R(2, 1)
Next F
End If
For Each SubFolder In StartFolder.SubFolders
If FullPaths = vbYes Then
R.Value = SubFolder.Path
Else
R.Value = SubFolder.Name
End If
If HyperlinkFolders = vbYes Then
R.Hyperlinks.Add R, "file://" & SubFolder.Path, , SubFolder.Name, SubFolder.Name
End If

Set R = R(2, 1)
If ShowFiles = vbYes Then
For Each F In SubFolder.Files
R(1, 2) = F.Name
If HyperlinkFiles = vbYes Then
R.Hyperlinks.Add R(1, 2), "file://" & F.Path, , F.Name, F.Name
End If
If ShowFileDetails = vbYes Then
R(1, 3).Value = F.Size
R(1, 4).Value = Format(F.DateLastModified, "dd-mmm-yyyy")
End If
Set R = R(2, 1)
Next F
End If
Next SubFolder
End Sub

Function BrowseFolder(Title As String, _
Optional InitialView As Office.MsoFileDialogView = _
msoFileDialogViewList) As String
Dim V As Variant
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = Title
.InitialView = InitialView
.Show
On Error Resume Next
Err.Clear
V = .SelectedItems(1)
If Err.Number <> 0 Then
V = vbNullString
End If
End With
BrowseFolder = CStr(V)
Application.ScreenUpdating = True

End Function