Sleeper: Is there a faster method to find extended file properties

[rlsbb1223]

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