If you want to get the names of all the folders in a directory/folder (Including Sub folders name).
Sub folder_names_including_subfolder()
Application.ScreenUpdating = False
Dim fldpath
Dim fso As Object, j As Long, folder1 As Object
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose the folder"
.Show
End With
On Error Resume Next
fldpath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
If fldpath = False Then
MsgBox "Folder Not Selected"
Exit Sub
End If
Workbooks.Add
Cells(1, 1).Value = fldpath
Cells(2, 1).Value = "Path"
Cells(2, 2).Value = "Dir"
Cells(2, 3).Value = "Name"
Cells(2, 4).Value = "Date Created"
Cells(2, 5).Value = "Date Last Modified"
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder1 = fso.getfolder(fldpath)
get_sub_folder folder1
Set fso = Nothing
Range("a1").Font.Size = 9
ActiveWindow.DisplayGridlines = False
Range("a3:e" & Range("a2").End(xlDown).Row).Font.Size = 9
Range("a2:e2").Interior.Color = vbCyan
Columns("c:h").AutoFit
Application.ScreenUpdating = True
End Sub
Sub get_sub_folder(ByRef prntfld As Object)
Dim SubFolder As Object, subfld As Object, j As Long
For Each SubFolder In prntfld.SubFolders
j = Range("A1").End(xlDown).Row + 1
Cells(j, 1).Value = SubFolder.Path
Cells(j, 2).Value = Left(SubFolder.Path, InStrRev(SubFolder.Path, "\"))
Cells(j, 3).Value = SubFolder.Name
Cells(j, 4).Value = SubFolder.DateCreated
Cells(j, 5).Value = SubFolder.DateLastModified
Next SubFolder
For Each subfld In prntfld.SubFolders
get_sub_folder subfld
Next subfld
End Sub
Sub folder_names_including_subfolder()
Application.ScreenUpdating = False
Dim fldpath
Dim fso As Object, j As Long, folder1 As Object
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose the folder"
.Show
End With
On Error Resume Next
fldpath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
If fldpath = False Then
MsgBox "Folder Not Selected"
Exit Sub
End If
Workbooks.Add
Cells(1, 1).Value = fldpath
Cells(2, 1).Value = "Path"
Cells(2, 2).Value = "Dir"
Cells(2, 3).Value = "Name"
Cells(2, 4).Value = "Date Created"
Cells(2, 5).Value = "Date Last Modified"
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder1 = fso.getfolder(fldpath)
get_sub_folder folder1
Set fso = Nothing
Range("a1").Font.Size = 9
ActiveWindow.DisplayGridlines = False
Range("a3:e" & Range("a2").End(xlDown).Row).Font.Size = 9
Range("a2:e2").Interior.Color = vbCyan
Columns("c:h").AutoFit
Application.ScreenUpdating = True
End Sub
Sub get_sub_folder(ByRef prntfld As Object)
Dim SubFolder As Object, subfld As Object, j As Long
For Each SubFolder In prntfld.SubFolders
j = Range("A1").End(xlDown).Row + 1
Cells(j, 1).Value = SubFolder.Path
Cells(j, 2).Value = Left(SubFolder.Path, InStrRev(SubFolder.Path, "\"))
Cells(j, 3).Value = SubFolder.Name
Cells(j, 4).Value = SubFolder.DateCreated
Cells(j, 5).Value = SubFolder.DateLastModified
Next SubFolder
For Each subfld In prntfld.SubFolders
get_sub_folder subfld
Next subfld
End Sub
Hi Team,
ReplyDeletePlease explain to me, Iam beginner for Excel VBA macros.
I want check image details from a folder, like image name, format, size, horizontal resolution, vertical resolution, height, width, overall dimensions, modified date, bit depth, color mode (RGB/CMYK) and compression (LZW/none for TIFF format).
I have searched in many forum, but didn't get proper info. And someone helped me to get image name, format, size, horizontal resolution, vertical resolution, height, width, modified date, bit depth and overall dimensions, except color mode (RGB/CMYK) and compression (LZW/none for TIFF format). Below mentioned code for this.
Sub GetImageInfo()
Dim i As Integer, SourceFldr
Dim c As Range, rng As Range
Dim sFile As Variant
Dim oWSHShell As Object
Dim fldr As FileDialog
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
Set oWSHShell = CreateObject("WScript.Shell")
With fldr
.Title = "Select a Source Folder"
.AllowMultiSelect = False
.InitialFileName = oWSHShell.SpecialFolders("Desktop")
If .Show <> -1 Then GoTo NextCode
SourceFldr = .SelectedItems(1)
NextCode:
End With
Dim oShell: Set oShell = CreateObject("Shell.Application")
Dim oDir: Set oDir = oShell.Namespace(SourceFldr)
i = 3
Range("A3:K5000").ClearContents
For Each sFile In oDir.Items
Cells(i, 1).Value = oDir.GetDetailsOf(sFile, 0)
Cells(i, 2).Value = oDir.GetDetailsOf(sFile, 1)
Cells(i, 3).Value = oDir.GetDetailsOf(sFile, 2)
Cells(i, 4).Value = oDir.GetDetailsOf(sFile, 5)
Cells(i, 5).Value = oDir.GetDetailsOf(sFile, 12)
Cells(i, 6).Value = oDir.GetDetailsOf(sFile, 31)
Cells(i, 7).Value = oDir.GetDetailsOf(sFile, 160)
Cells(i, 8).Value = oDir.GetDetailsOf(sFile, 164)
Cells(i, 9).Value = oDir.GetDetailsOf(sFile, 162)
Cells(i, 10).Value = oDir.GetDetailsOf(sFile, 161)
Cells(i, 11).Value = oDir.GetDetailsOf(sFile, 163)
i = i + 1
Next
Set oDir = Nothing
Set oShell = Nothing
Cells.Columns.AutoFit
MsgBox "Done"
End Sub
Someone suggested me to use third party DLLs (imagemagick, and so on) u will definitely get all image details, but i dont know how to use, bcoz m beginner for VBA.
Pls help me