Hi Greg
Here's a set of code that does it. Paste in a standard module:
Option Explicit
Enum BrowseForFolderFlags
BIF_RETURNONLYFSDIRS = &H1
BIF_DONTGOBELOWDOMAIN = &H2
BIF_STATUSTEXT = &H4
BIF_BROWSEFORCOMPUTER = &H1000
BIF_BROWSEFORPRINTER = &H2000
BIF_BROWSEINCLUDEFILES = &H4000
BIF_EDITBOX = &H10
BIF_RETURNFSANCESTORS = &H8
End Enum
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
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
Dim Writerow As Long
Public Function BrowseForFolder(hWnd As Long, _
Optional Title As String, _
Optional Flags As BrowseForFolderFlags) As String
Dim iNull As Integer
Dim IDList As Long
Dim Result As Long
Dim Path As String
Dim bi As BrowseInfo
If Flags = 0 Then Flags = BIF_RETURNONLYFSDIRS
With bi
.lpszTitle = lstrcat(Title, "")
.ulFlags = Flags
End With
IDList = SHBrowseForFolder(bi)
If IDList Then
Path = String$(300, 0)
Result = SHGetPathFromIDList(IDList, Path)
iNull = InStr(Path, vbNullChar)
If iNull Then Path = Left$(Path, iNull - 1)
End If
BrowseForFolder = Path
End Function
Sub ListMyFiles()
Dim DirToSearch As String
Dim WithSubFolders As Boolean
Writerow = ActiveSheet.Cells(65000, 1).End(xlUp).Row + 1
DirToSearch = BrowseForFolder(858, _
"Choose a folder:", BIF_DONTGOBELOWDOMAIN)
If DirToSearch < "" Then
WithSubFolders = (MsgBox("Include subfolders ?", _
vbYesNo + vbQuestion, "Files in " & DirToSearch) = vbYes)
GetFilesInDirectory DirToSearch
If WithSubFolders Then LookForDirectories (DirToSearch)
End If
End Sub
Sub LookForDirectories(ByVal DirToSearch As String)
Dim counter As Integer
Dim i As Integer
Dim Directories() As String
Dim Contents As String
counter = 0
DirToSearch = DirToSearch & "\"
Contents = Dir(DirToSearch, vbDirectory)
Do While Contents < ""
If Contents < "." And Contents < ".." Then
If (GetAttr(DirToSearch & Contents) And _
vbDirectory) = vbDirectory Then
counter% = counter% + 1
ReDim Preserve Directories(counter)
Directories(counter) = DirToSearch & Contents
End If
End If
Contents = Dir
Loop
If counter = 0 Then Exit Sub
For i = 1 To counter
GetFilesInDirectory Directories(i)
LookForDirectories Directories(i)
Next i
End Sub
Sub GetFilesInDirectory(ByVal DirToSearch As String)
Dim NextFile As String
On Error Resume Next
With ActiveSheet
NextFile = Dir(DirToSearch & "\" & "*.*")
Do Until NextFile = ""
.Cells(Writerow, 1) = DirToSearch & "\"
.Cells(Writerow, 2) = NextFile
.Cells(Writerow, 3) = FileDateTime(DirToSearch & _
"\" & NextFile)
.Cells(Writerow, 4) = Format(FileLen(DirToSearch & _
"\" & NextFile) / 1024, "# ##0 Kb")
Writerow = Writerow + 1
NextFile = Dir()
Loop
End With
End Sub
HTH. Best wishes Harald
"Greg B" skrev i melding
...
Is there anyway to have excel list files in a dirctory?
Thanks in advance.
Greg
|