' _,
' ___ _ _ _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'
'-----------------------------------
' Lâìy danh sách têòp trong thý muòc
Sub ListAllFiles(ByVal Paths, _
ByRef Files(), _
Optional ByRef FSO As Object, _
Optional ByVal IncludeSubfolders As Boolean = False, _
Optional ByVal Types As Variant = "*", _
Optional ByVal NameTypes As Variant = "", _
Optional ByVal FileNameLike As Variant = "*", _
Optional ByVal FolderNameLike As Variant = "*", _
Optional ByVal RunProcedureDeleteIfWrongConditions As String, _
Optional ByVal IsGetFileObject As Boolean, _
Optional ByVal ReturnOrder As Integer, Optional ByVal ReturnName1 As Integer, Optional ByVal ReturnName2 As Integer, _
Optional ByVal ReturnSize As Integer, Optional ByVal ReturnLength As Integer, _
Optional ByVal ReturnExtend As Integer, Optional ByVal ReturnType As Integer, _
Optional ByVal ReturnPathBetween As Integer, Optional ByVal ReturnFullPath As Integer, _
Optional ByVal ReturnParentFolder As Integer, Optional ByVal ReturnAttributes As Integer, _
Optional ByVal ReturnShortName As Integer, Optional ByVal ReturnShortPath As Integer, _
Optional ByVal ReturnDateCreated As Integer, _
Optional ByVal ReturnDateLastAccessed As Integer, _
Optional ByVal ReturnDateLastModified As Integer, _
Optional ByVal MainPath$)
' Last Edit: 25/09/2020 08:10
On Error Resume Next
DoEvents
Dim K As Long
Dim R As Long, Cols%, C%, A(16)
Dim Correct As Boolean
Dim ItemName As String
Dim ItemType As String
Dim Ext As String
Dim aTypes() As String
Dim sLike() As String
Dim Arr() As String
Dim Folders() As String
Dim SF
Dim Item As Object 'Scripting.File
Dim Folder
Dim oFolder
'-------------------------------------------
C = 1
A(C) = ReturnOrder: GoSub g
A(C) = ReturnName1: GoSub g
A(C) = ReturnName2: GoSub g
A(C) = ReturnSize: GoSub g
A(C) = ReturnLength: GoSub g
A(C) = ReturnExtend: GoSub g
A(C) = ReturnType: GoSub g
A(C) = ReturnPathBetween: GoSub g
A(C) = ReturnFullPath: GoSub g
A(C) = ReturnParentFolder: GoSub g
A(C) = ReturnAttributes: GoSub g
A(C) = ReturnShortName: GoSub g
A(C) = ReturnShortPath: GoSub g
A(C) = ReturnDateCreated: GoSub g
A(C) = ReturnDateLastAccessed: GoSub g
A(C) = ReturnDateLastModified: GoSub g
'-------------------------------------------
If VBA.TypeName(Paths) = "String" Then Paths = Array(Paths)
If MainPath = vbNullString Then MainPath = Paths(0)
'-------------------------------------------
If VBA.TypeName(FileNameLike) = "String" Then
If FileNameLike <> vbNullString Then
Arr = VBA.Split(FileNameLike, "|")
ReDim sLike(UBound(Arr))
If VBA.Err = 0 Then
For R = LBound(Arr) To UBound(Arr)
sLike(R) = "*" & VBA.LCase(Arr(R)) & "*"
Next R
End If
End If
Else
ReDim sLike(UBound(FileNameLike))
If VBA.Err = 0 Then
For R = LBound(FileNameLike) To UBound(FileNameLike)
sLike(R) = "*" & VBA.LCase(FileNameLike(R)) & "*"
Next R
End If
End If '-------------------------------------------
R = 0
VBA.Err.clear
If VBA.TypeName(NameTypes) = "String" Then
If NameTypes <> vbNullString Then
Arr = VBA.Split(NameTypes, ",")
ReDim aTypes(UBound(Arr))
If VBA.Err = 0 Then
For R = LBound(Arr) To UBound(Arr)
aTypes(R) = VBA.Trim(VBA.LCase(Arr(R)))
Next R
End If
End If
Else
ReDim aTypes(UBound(NameTypes))
If VBA.Err = 0 Then
For R = LBound(NameTypes) To UBound(NameTypes)
aTypes(R) = VBA.Trim(VBA.LCase(NameTypes(R)))
Next R
End If
End If
VBA.Err.clear
'-------------------------------------------
If VBA.TypeName(Types) = "String" Then
If Types <> vbNullString Then
Arr = VBA.Split(Types, ",")
ReDim Preserve aTypes(R + UBound(Arr))
If VBA.Err = 0 Then
For R = LBound(Arr) To UBound(Arr)
aTypes(R) = VBA.Trim(VBA.LCase(Arr(R)))
If Not aTypes(R) Like "[*]*" Then
aTypes(R) = "*" & aTypes(R)
End If
Next R
End If
End If
Else
ReDim aTypes(UBound(Types) + VBA.IIf(R = -1, 0, R))
If VBA.Err = 0 Then
For K = LBound(Types) To UBound(Types)
If Not Types(K) Like "[*]*" Then
aTypes(K + VBA.IIf(R = -1, 0, R)) = "*" & VBA.LCase(Types(K))
Else
aTypes(K + VBA.IIf(R = -1, 0, R)) = VBA.LCase(Types(K))
End If
Next K
End If
End If
'-------------------------------------------
If FSO Is Nothing Then Set FSO = VBA.CreateObject("Scripting.FileSystemObject")
'-------------------------------------------
R = 0
R = UBound(Files, 2)
For Each Folder In Paths
If FSO.FolderExists(Folder) Then
Set oFolder = FSO.GetFolder(Folder)
For Each Item In oFolder.Files
ItemName = vbNullString: ItemName = VBA.LCase(Item.Name)
Ext = VBA.LCase(VBA.Trim(VBA.RIGHT(VBA.Replace(ItemName, ".", VBA.Space(255)), 255)))
ItemName = VBA.LEFT(ItemName, Len(ItemName) - Len(Ext) - 1)
ItemType = vbNullString: ItemType = VBA.LCase(Item.Type)
Correct = False
For Each SF In aTypes
If VBA.LEFT(ItemName, 1) <> "~" And ("." & Ext Like SF Or ItemType = SF) Then
Correct = True: Exit For
End If
Next SF
If Correct And FileNameLike <> "*" And FileNameLike <> "" Then
For Each SF In sLike
If ItemName Like SF Then Correct = True: GoTo GetItem
Next SF
Correct = False
End If
GetItem:
If Correct Then
R = R + 1
If Not IsGetFileObject Then
ReDim Preserve Files(1 To Cols, 1 To R)
With Item
C = 1: If A(C) > 0 Then Files(A(C), R) = R
C = C + 1: If A(C) > 0 Then Files(A(C), R) = .Name
C = C + 1: If A(C) > 0 Then Files(A(C), R) = VBA.LEFT(.Name, Len(.Name) - Len(Ext) - 1)
C = C + 1: If A(C) > 0 Then Files(A(C), R) = VBA.Round(.Size / 1024 / 1024, 2)
C = C + 1
If A(C) > 0 Then
Static Sh As Object
If Sh Is Nothing Then Set Sh = VBA.CreateObject("Shell.Application")
Dim ShFolder As Object, ParseName As Object, tTime As String
Set ShFolder = Sh.Namespace(CVar(.ParentFolder & "\"))
Set ParseName = ShFolder.ParseName(.Name)
If Not ParseName Is Nothing Then _
Files(A(C), R) = ShFolder.GetDetailsOf(ShFolder.ParseName(.Name), 27)
Set ParseName = Nothing
End If
C = C + 1: If A(C) > 0 Then Files(A(C), R) = Ext
C = C + 1: If A(C) > 0 Then Files(A(C), R) = .Type
C = C + 1
If A(C) > 0 Then
Files(A(C), R) = Replace(.path, MainPath, "", , , 1)
Files(A(C), R) = Replace(Files(A(C), R), .Name, "", , , 1)
End If
C = C + 1: If A(C) > 0 Then Files(A(C), R) = .path
C = C + 1: If A(C) > 0 Then Files(A(C), R) = .ParentFolder
C = C + 1: If A(C) > 0 Then Files(A(C), R) = .Attributes
C = C + 1: If A(C) > 0 Then Files(A(C), R) = .ShortName
C = C + 1: If A(C) > 0 Then Files(A(C), R) = .ShortPath
C = C + 1: If A(C) > 0 Then Files(A(C), R) = CDate(.DateCreated)
C = C + 1: If A(C) > 0 Then Files(A(C), R) = CDate(.DateLastAccessed)
C = C + 1: If A(C) > 0 Then Files(A(C), R) = CDate(.DateLastModified)
End With
Else
ReDim Preserve Files(1 To R)
Set Files(R) = Item
End If
Else
If RunProcedureDeleteIfWrongConditions <> "" Then
Application.Run RunProcedureDeleteIfWrongConditions, Item.path
End If
End If
Next Item
CheckSub:
If IncludeSubfolders Then
For Each SF In oFolder.SubFolders
If VBA.LCase(SF.Name) Like VBA.LCase(FolderNameLike) Then
K = K + 1: ReDim Preserve Folders(1 To K): Folders(K) = SF.path
End If
Next SF
End If
End If
Next Folder
If IncludeSubfolders And K > 0 Then
Call ListAllFiles(Folders, Files, FSO, True, Types, NameTypes, _
FileNameLike, FolderNameLike, RunProcedureDeleteIfWrongConditions, _
IsGetFileObject, _
ReturnOrder, ReturnName1, ReturnName2, ReturnSize, ReturnLength, ReturnExtend, ReturnType, _
ReturnPathBetween, ReturnFullPath, ReturnParentFolder, _
ReturnAttributes, ReturnShortName, ReturnShortPath, _
ReturnDateCreated, ReturnDateLastAccessed, ReturnDateLastModified, MainPath)
End If
On Error GoTo 0
Exit Sub
g:
If A(C) > Cols Then Cols = A(C)
C = C + 1
Return
End Sub
' _,
' ___ _ _ _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'
Sub ListAllFolder(ByVal Paths, _
ByRef Folders(), _
Optional ByRef FSO As Object, _
Optional ByVal IncludeSubfolders As Boolean = False, _
Optional ByVal FolderNameLike = "*", _
Optional ByVal IsGetFileObject As Boolean, _
Optional ByVal ReturnOrder As Integer, _
Optional ByVal ReturnName As Integer, _
Optional ByVal ReturnSize As Integer, _
Optional ByVal ReturnFullPath As Integer, _
Optional ByVal ReturnParentFolder As Integer, _
Optional ByVal ReturnShortPath As Integer, _
Optional ByVal ReturnDateCreated As Integer, _
Optional ByVal ReturnDateLastAccessed As Integer, _
Optional ByVal ReturnDateLastModified As Integer)
Dim R&, C%, K&, LB%, UB&, Arr(), dArr(), Folder, Cols%, A(9)
Dim Item As Object 'Scripting.Folder
Dim oFolder As Object ''Scripting.Folder
'-------------------------------------------
C = 1
A(C) = ReturnOrder: GoSub g
A(C) = ReturnName: GoSub g
A(C) = ReturnSize: GoSub g
A(C) = ReturnFullPath: GoSub g
A(C) = ReturnParentFolder: GoSub g
A(C) = ReturnShortPath: GoSub g
A(C) = ReturnDateCreated: GoSub g
A(C) = ReturnDateLastAccessed: GoSub g
A(C) = ReturnDateLastModified: GoSub g
If VBA.TypeName(Paths) = "String" Then Paths = Array(Paths)
If FSO Is Nothing Then
Set FSO = VBA.CreateObject("Scripting.FileSystemObject")
End If
On Error Resume Next
R = UBound(Folders)
For Each Folder In Paths
If FSO.FolderExists(Folder) Then
Set oFolder = FSO.GetFolder(Folder)
For Each Item In oFolder.SubFolders
K = K + 1: ReDim Preserve dArr(1 To K)
dArr(K) = Item.path
R = R + 1
If Not IsGetFileObject Then
ReDim Preserve Folders(1 To Cols, 1 To R)
C = 0
With Item
C = 1
If A(C) > 0 Then: Folders(A(C), R) = R
C = C + 1
If A(C) > 0 Then: Folders(A(C), R) = .Name
C = C + 1
If A(C) > 0 Then: Folders(A(C), R) = VBA.Round(.Size / 1024 / 1024, 2)
C = C + 1
If A(C) > 0 Then: Folders(A(C), R) = .path
C = C + 1
If A(C) > 0 Then: Folders(A(C), R) = .ParentFolder
C = C + 1
If A(C) > 0 Then: Folders(A(C), R) = .ShortPath
C = C + 1
If A(C) > 0 Then: Folders(A(C), R) = .DateCreated
C = C + 1
If A(C) > 0 Then: Folders(A(C), R) = .DateLastAccessed
C = C + 1
If A(C) > 0 Then: Folders(A(C), R) = .DateLastModified
End With
Else
ReDim Preserve Folders(1 To R)
Set Folders(R) = Item
End If
Next Item
End If
Next Folder
If K > 0 And IncludeSubfolders Then
Call ListAllFolder(dArr, Folders, FSO, True, FolderNameLike, _
ReturnOrder, ReturnName, ReturnSize, _
ReturnFullPath, ReturnParentFolder, ReturnShortPath, _
ReturnDateCreated, ReturnDateLastAccessed, ReturnDateLastModified)
End If
Exit Sub
g:
If Cols < A(C) Then Cols = A(C)
C = C + 1
Return
End Sub
