Hi
as a starting point a repost from bob Phillips:
----------------
Option Explicit
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, _
ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As Long
Private 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
Dim FSO As Object
Dim cnt As Long
Dim level As Long
Dim arFiles
Sub Folders()
Dim i As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
arFiles = Array()
cnt = 0
level = 1
ReDim arFiles(3, 0)
arFiles(0, 0) = GetFolder()
If arFiles(0, 0) <> "" Then
arFiles(1, 0) = level
SelectFiles arFiles(0, 0)
Worksheets.Add.Name = "Files"
With ActiveSheet
.Cells(1, 1).Value = "Path"
.Cells(1, 2).Value = "Filename"
.Cells(1, 3).Value = "Date Created"
.Cells(1, 4).Value = "Filesize"
.Rows(1).Font.Bold = True
.Columns(4).NumberFormat = "#,##0 "" KB"""
.Columns("A
").EntireColumn.AutoFit
cnt = 1
For i = LBound(arFiles, 2) To UBound(arFiles, 2)
.Cells(i + 2, 1).Value = arFiles(0, i)
.Cells(i + 2, 2).Value = arFiles(1, i)
.Cells(i + 2, 3).Value = arFiles(2, i)
.Cells(i + 2, 4).Value = arFiles(3, i) / 1024
Next
End With
End If
End Sub
'----------------------------------------------------------------------
-
Sub SelectFiles(ByVal sPath)
'----------------------------------------------------------------------
-
Dim fldr As Object
Dim Folder As Object
Dim file As Object
Dim Files As Object
Set Folder = FSO.GetFolder(sPath)
Set Files = Folder.Files
For Each file In Files
If (file.Attributes And 2 Or _
file.Attributes And 4) Then
'2 is hidden, 4 is system
Else
cnt = cnt + 1
ReDim Preserve arFiles(3, cnt)
arFiles(0, cnt) = Folder.path
arFiles(1, cnt) = file.Name
arFiles(2, cnt) = Format(file.DateCreated, "dd mmm yyyy")
arFiles(3, cnt) = file.Size
End If
Next file
level = level + 1
For Each fldr In Folder.Subfolders
SelectFiles fldr.path
Next
End Sub
'-------------------------------------------------------------
Function GetFolder(Optional ByVal Name As String = "Select a
folder.") As String
'-------------------------------------------------------------
Dim bInfo As BROWSEINFO
Dim path As String
Dim oDialog As Long
bInfo.pidlRoot = 0& 'Root folder = Desktop
bInfo.lpszTitle = Name
bInfo.ulFlags = &H1 'Type of directory to
Return
oDialog = SHBrowseForFolder(bInfo) 'display the dialog
'Parse the result
path = Space$(512)
GetFolder = ""
If SHGetPathFromIDList(ByVal oDialog, ByVal path) Then
GetFolder = Left(path, InStr(path, Chr$(0)) - 1)
End If
End Function
