rlsbb1223
10-20-2021, 08:05 PM
EDIT!
Solved using arrays. Now I have a separate Issue. Is there a reason:
ActiveSheet.Range("C" & Lrow) = oDir.GetDetailsOf(sFile, AttribName)
Comes out as the title of the property instead of the the property, i.e Name instead of 123456.prt
Sub Recursive(FolderPath As Variant)
Dim Value As String, Folders() As String
Dim Folder As Variant, a As Long
Dim AttribName As Long
Dim sFile As Long
AttribName = 327
Dim oShell: Set oShell = CreateObject("Shell.Application")
Dim oDir: Set oDir = oShell.Namespace(FolderPath)
ReDim Folders(0)
If Right(FolderPath, 2) = "\\" Then Exit Sub
Value = Dir(FolderPath, &H1F)
Do Until Value = ""
If Value = "." Or Value = ".." Then
Else
If GetAttr(FolderPath & Value) = 16 Or GetAttr(FolderPath & Value) = 48 Then
Folders(UBound(Folders)) = Value
ReDim Preserve Folders(UBound(Folders) + 1)
Else
Lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
ActiveSheet.Range("A" & Lrow) = FolderPath
ActiveSheet.Range("B" & Lrow) = Value
ActiveSheet.Range("C" & Lrow) = oDir.GetDetailsOf(sFile, AttribName)
End If
End If
Value = Dir
Loop
For Each Folder In Folders
Recursive FolderPath & Folder & "\"
Next Folder
End Sub
Im currently using the following code, mainly to extract the "Description" from the file properties of CAD part files.
It works well for the most part however, some folders have around 3000 parts, each varying between 50kb and 100kb, so when I use this code, it takes close to 20mins to run.
Is there a better way of doing this? my aim in the end is to have a recursive script that can search subfolders too:
ORIGINAL POST:
Sub CommandButton()
'Show Filename, Attribute Name and Attribute Value in Columns A,B,C
Dim sFile As Variant
Dim oShell: Set oShell = CreateObject("Shell.Application")
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.title = "Select a location containing the files you want to list."
If .Show Then
If .SelectedItems.Count > 0 Then
d = .SelectedItems(1)
End If
End If
End With
Dim oDir: Set oDir = oShell.Namespace(d)
Dim AttribName As Long
AttribName = 327
'Insert a new sheet
Sheets.Add
Set x = ActiveSheet
'Get a list of first folderīs content to a sheet
Application.ScreenUpdating = False
x.Range("A1") = "Files"
x.Range("A2") = "Path"
x.Range("B2") = "File Name"
x.Range("C2") = "Description"
x.Range("A:F").Font.Bold = False
x.Range("A1:C2").Font.Bold = True
For Each sFile In oDir.Items
Lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
ActiveSheet.Range("A" & Lrow) = oDir.GetDetailsOf(sFile, 191)
ActiveSheet.Range("B" & Lrow) = oDir.GetDetailsOf(sFile, 0)
ActiveSheet.Range("C" & Lrow) = oDir.GetDetailsOf(sFile, AttribName)
Next
Columns("A:M").AutoFit
ActiveSheet.Range("A:M").HorizontalAlignment = xlLeft
End Sub
Solved using arrays. Now I have a separate Issue. Is there a reason:
ActiveSheet.Range("C" & Lrow) = oDir.GetDetailsOf(sFile, AttribName)
Comes out as the title of the property instead of the the property, i.e Name instead of 123456.prt
Sub Recursive(FolderPath As Variant)
Dim Value As String, Folders() As String
Dim Folder As Variant, a As Long
Dim AttribName As Long
Dim sFile As Long
AttribName = 327
Dim oShell: Set oShell = CreateObject("Shell.Application")
Dim oDir: Set oDir = oShell.Namespace(FolderPath)
ReDim Folders(0)
If Right(FolderPath, 2) = "\\" Then Exit Sub
Value = Dir(FolderPath, &H1F)
Do Until Value = ""
If Value = "." Or Value = ".." Then
Else
If GetAttr(FolderPath & Value) = 16 Or GetAttr(FolderPath & Value) = 48 Then
Folders(UBound(Folders)) = Value
ReDim Preserve Folders(UBound(Folders) + 1)
Else
Lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
ActiveSheet.Range("A" & Lrow) = FolderPath
ActiveSheet.Range("B" & Lrow) = Value
ActiveSheet.Range("C" & Lrow) = oDir.GetDetailsOf(sFile, AttribName)
End If
End If
Value = Dir
Loop
For Each Folder In Folders
Recursive FolderPath & Folder & "\"
Next Folder
End Sub
Im currently using the following code, mainly to extract the "Description" from the file properties of CAD part files.
It works well for the most part however, some folders have around 3000 parts, each varying between 50kb and 100kb, so when I use this code, it takes close to 20mins to run.
Is there a better way of doing this? my aim in the end is to have a recursive script that can search subfolders too:
ORIGINAL POST:
Sub CommandButton()
'Show Filename, Attribute Name and Attribute Value in Columns A,B,C
Dim sFile As Variant
Dim oShell: Set oShell = CreateObject("Shell.Application")
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.title = "Select a location containing the files you want to list."
If .Show Then
If .SelectedItems.Count > 0 Then
d = .SelectedItems(1)
End If
End If
End With
Dim oDir: Set oDir = oShell.Namespace(d)
Dim AttribName As Long
AttribName = 327
'Insert a new sheet
Sheets.Add
Set x = ActiveSheet
'Get a list of first folderīs content to a sheet
Application.ScreenUpdating = False
x.Range("A1") = "Files"
x.Range("A2") = "Path"
x.Range("B2") = "File Name"
x.Range("C2") = "Description"
x.Range("A:F").Font.Bold = False
x.Range("A1:C2").Font.Bold = True
For Each sFile In oDir.Items
Lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
ActiveSheet.Range("A" & Lrow) = oDir.GetDetailsOf(sFile, 191)
ActiveSheet.Range("B" & Lrow) = oDir.GetDetailsOf(sFile, 0)
ActiveSheet.Range("C" & Lrow) = oDir.GetDetailsOf(sFile, AttribName)
Next
Columns("A:M").AutoFit
ActiveSheet.Range("A:M").HorizontalAlignment = xlLeft
End Sub