Public Sub ListFilesAndFolders(ByVal FolderStart As String, result, Optional fso As Object, Optional ByVal sFilter As String = "", _
Optional ByVal inSub As Boolean = False, Optional level As Long)
' kết quả trả về trong mảng result có 3 hàng và nhiều cột - chỉ số hàng và cột tính từ 1.
' Mỗi cột của mảng result có đường dẫn đầy đủ của tập tin ở hàng 1, ở hàng 2 là level của tập tin ở hàng 1, còn
' hàng 3 = TRUE (FALSE) ứng với hàng 1 là đường dẫn tới thư mục (tập tin).
' nếu lấy tất cả các tập tin thì sFilter = "" (đã là mặc định nên có thể bỏ qua)
' nếu chỉ lấy vd. các tập tin JPG thì sFilter = "*.jpg"
' nếu lấy các tập tin JPG mà tên phải chứa "hichic" thì nhập sFilter = "*hichic*.jpg"
' nếu tìm cả trong các thư mục con thì inSub = TRUE, ngược lại thì inSub = False. Mặc định là inSub = False.
' hàm bắt đầu tìm trong thư mục FolderStart
' có thể truyền tham số fso và level nhưng không bắt buộc.
Dim count As Long, f As Object, SubF As Object, files As Object
If fso Is Nothing Then Set fso = CreateObject("Scripting.FileSystemObject")
If level = 0 Then level = 1
If fso.FolderExists(FolderStart) Then
If IsEmpty(result) Then
ReDim result(1 To 3, 1 To 1)
count = 0
Else
count = UBound(result, 2)
End If
count = count + 1
ReDim Preserve result(1 To 3, 1 To count)
result(1, count) = FolderStart
result(2, count) = level
result(3, count) = True
level = level + 1
If sFilter = "" Then sFilter = "*"
Set f = fso.GetFolder(FolderStart)
On Error Resume Next
count = f.files.count
If Err.Number Then
Err.Clear
On Error GoTo 0
Else
On Error GoTo 0
Set files = f.files
For Each SubF In files
If LCase(SubF.Name) Like LCase(sFilter) Then
ReDim Preserve result(1 To 3, 1 To UBound(result, 2) + 1)
result(1, UBound(result, 2)) = SubF.Path
result(2, UBound(result, 2)) = level
result(3, UBound(result, 2)) = False
End If
Next SubF
If inSub Then
For Each SubF In f.SubFolders
ListFilesAndFolders SubF.Path, result, fso, sFilter, True, level
Next
End If
End If
Set f = Nothing
level = level - 1
End If
End Sub
'Sub batman1()
'Dim r As Long, level As Long, fso As Object, result, kq()
'' xóa kết quả cũ
' Sheet1.UsedRange.Clear
'' tất cả các tập tin trong thư mục "c:\1" và các thư mục con, chỉ tên thôi.
' Set fso = CreateObject("Scripting.FileSystemObject")
' ListFilesAndFolders "c:\1", result, , "", True
' If Not IsEmpty(result) Then
' ReDim kq(1 To UBound(result, 2), 1 To 1)
' For r = 1 To UBound(result, 2)
' level = result(2, r)
' If UBound(kq, 2) < level Then ReDim Preserve kq(1 To UBound(kq, 1), 1 To level)
' If r = 1 Then
' kq(r, level) = result(1, r)
' Else
' kq(r, level) = fso.GetBaseName(result(1, r))
' End If
' Next r
' Sheet1.Range("A2").Resize(UBound(kq, 1), UBound(kq, 2)).Value = kq
' End If
' Set fso = Nothing
'End Sub
Sub buivantinh()
Dim r As Long, level As Long, text As String, fso As Object, result, rng As Range
' xóa kết quả cũ
Sheet1.UsedRange.Clear
' tất cả các tập tin trong thư mục "c:\1" và các thư mục con, chỉ tên thôi.
Set fso = CreateObject("Scripting.FileSystemObject")
ListFilesAndFolders "c:\1", result, , "", True
If Not IsEmpty(result) Then
For r = 1 To UBound(result, 2)
level = result(2, r)
If result(3, r) Then ' là thư mục -> gom các ô để dùng chữ đỏ.
If rng Is Nothing Then
Set rng = Sheet1.Cells(r, level)
Else
Set rng = Union(rng, Sheet1.Cells(r, level))
End If
End If
If r = 1 Then
text = result(1, r)
Else
text = fso.GetBaseName(result(1, r))
End If
Sheet1.Hyperlinks.Add Anchor:=Sheet1.Cells(r, level), Address:=result(1, r), TextToDisplay:=text
Next r
If Not rng Is Nothing Then rng.Font.Color = RGB(255, 0, 0)
End If
Set fso = Nothing
End Sub
