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

EDIT!
Solved using arrays. Now I have a separate Issue. Is there a reason:

Code:

---

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

Code:

---

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:

Code:

---

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

---

Are you trying to rebuild the explorer ?

Since the file properties change from OS version to OS version, you need to take the property (e.g. "Attributes") and get the field number (e.g. 6) (faGetFieldNumber) first and look it up by that

Code:

---

Option Explicit


Sub drv()
    MsgBox faGetFileProperty("C:\Users\Daddy\Desktop\Fonts.xlsm", "Attributes")
End Sub




Function faGetFileProperty(sFilename As String, sProperty As String) As Variant
    Dim iProp As Long
    Dim oFolder As Object, oFolderItem As Object
    Dim iFieldNumber As Long
    Dim sFolder As String, sFile As String
   
    faGetFileProperty = vbNullString


    On Error GoTo NiceExit
    iProp = faGetFieldNumber(sProperty)
   
    If iProp = -1 Then Exit Function


    With CreateObject("scripting.FileSystemObject")
        sFolder = .GetParentFolderName(sFilename)
        sFile = .GetFileName(sFilename)
    End With
   
    Set oFolder = CreateObject("shell.application").Namespace(sFolder & "\")
    Set oFolderItem = oFolder.ParseName(sFile)
   
    faGetFileProperty = oFolder.GetDetailsOf(oFolderItem, iProp)


NiceExit:


End Function


Function faGetFieldNumber(s) As Long
    Dim oFolder As Object
    Dim n As Long
    Dim sDesktop As Variant
   
    sDesktop = CreateObject("wscript.shell").specialfolders(10) & Application.PathSeparator
    Set oFolder = CreateObject("shell.application").Namespace(sDesktop)
   
    On Error GoTo Oops
   
        For n = 0 To 999
        If LCase(s) = LCase(oFolder.GetDetailsOf(oFolder.items, n)) Then
            faGetFieldNumber = n
            Exit Function
        End If
    Next n


Oops:
    Set oFolder = Nothing
    faGetFieldNumber = -1
   
End Function

---

Thanks for the reply Paul.

I used the following code to find the field number I needed

Code:

---

Private Sub CommandButton1_Click()' Show all known file attribute number designations..
Dim sFile As Variant
Dim oShell: Set oShell = CreateObject("Shell.Application")
Dim oDir: Set oDir = oShell.Namespace("INSERTFOLDER")
Dim a As String
For i = 0 To 386
 Cells(i + 1, 1).Value = oDir.GetDetailsOf(oDir.Items, i) & " = " & i
Next
End Sub

---

But putting any field number into my code just returns the title of the field

I don't know what INSERTFOLDER is

This works

Code:

---

Option Explicit


Private Sub CommandButton1_Click() ' Show all known file attribute number designations..
    Dim i As Long
    Dim sFile As Variant
    Dim oShell: Set oShell = CreateObject("Shell.Application")
    Dim oDir: Set oDir = oShell.Namespace(Environ("USERPROFILE") & "\Desktop")
    Dim a As String


    For i = 0 To 386
        Cells(i + 1, 1).Value = oDir.GetDetailsOf(oDir.Items, i) & " = " & i
    Next
End Sub

---

Name = 0

Size = 1

Item type = 2

Date modified = 3

Date created = 4

Date accessed = 5

Attributes = 6

Offline status = 7

Availability = 8

Perceived type = 9

Owner = 10

Kind = 11

Date taken = 12

Contributing artists = 13

Album = 14

Year = 15

Genre = 16

Conductors = 17

Tags = 18

Rating = 19

Authors = 20

Title = 21

Subject = 22

Categories = 23

Comments = 24

Copyright = 25

# = 26

Length = 27

Bit rate = 28

Protected = 29

Camera model = 30

Dimensions = 31

Camera maker = 32

Company = 33

File description = 34

Masters keywords = 35

Masters keywords = 36

= 37

= 38

= 39

= 40

= 41

Code:

---

Sub M_snb()
    For Each fl In CreateObject("shell.application").Namespace("G:\OF").Items
        c02 = ""
        With fl.Parent
            For j = 0 To 14
                c02 = c02 & vbLf & j & vbTab & .GetDetailsOf(.Items, j) & ": " & .GetDetailsOf(fl, j)
            Next
        End With
        MsgBox c02
    Next
End Sub

---

@PH

Internationally more robust:

Code:

---

    MsgBox CreateObject("wscript.shell").specialfolders(10)

---

By the way.


When is SpecialFolders(10) and when SpecialFolders(4)? Because for me both paths are the same.

Artik

Using Windows 10, the easiest way I know to get the special folder enums is

Code:

---

Option Explicit


Sub ListSpecialFolders()
    Dim i As Long
   
    With CreateObject("Shell.Application")
        For i = 0 To 99
            Cells(i + 1, 1) = i
            On Error Resume Next
            Cells(i + 1, 2) = .Namespace(CVar(i)).Self
            Cells(i + 1, 3) = .Namespace(CVar(i)).Self.Path
            On Error GoTo 0
        Next i
    End With
End Sub

---

Attachment 29083

Quote:

---

Originally Posted by Artik

By the way.
When is SpecialFolders(10) and when SpecialFolders(4)? Because for me both paths are the same.
Artik

---

It is only a matter of testing/finding out.
Nobody is capable of finding any system/structure in MS's OS 'upgrading' policy.

This post is more directed towards Paul.

I use a different list. I pay attention to another object from which data is collected.

Code:

---

Sub ListSpecialFolderPaths()

    Dim WSHShell    As Object
    Dim strPath    As String
    Dim strFolderName As String
    Dim intLoop    As Integer

    Set WSHShell = CreateObject("Wscript.Shell")

    For intLoop = 0 To WSHShell.SpecialFolders.Count - 1
        strPath = WSHShell.SpecialFolders(intLoop)
        strFolderName = Mid(strPath, InStrRev(strPath, Application.PathSeparator) + 1)

        Cells(intLoop + 1, 1) = intLoop
        Cells(intLoop + 1, 2) = strFolderName
        Cells(intLoop + 1, 3) = strPath
    Next intLoop

    Set WSHShell = Nothing
End Sub

---

Artik

@Artik

Code:

---

Sub M_snb()
    For Each it In CreateObject("wscript.shell").specialfolders
      c00 = c00 & vbLf & CreateObject("scripting.filesystemobject").getfolder(it).Name & vbTab & vbTab & it
    Next
    MsgBox c00
End Sub

---

CreateObject("Shell.Application") returns 56 Special folders, while CreateObject("Wscript.Shell") only returns a subset of 18

Almost all of the additional ones are Windows or Public related. Some are not.

I did a compare to see the differences in returned special folders

Your choice

Code:

---

Option Explicit


Sub Artik()


    Dim WSHShell    As Object
    Dim strPath    As String
    Dim strFolderName As String
    Dim intLoop    As Integer


    Set WSHShell = CreateObject("Wscript.Shell")


    For intLoop = 0 To WSHShell.specialfolders.Count - 1
        strPath = WSHShell.specialfolders(intLoop)
        strFolderName = Mid(strPath, InStrRev(strPath, Application.PathSeparator) + 1)


        Worksheets("Artik").Cells(intLoop + 1, 1) = intLoop
        Worksheets("Artik").Cells(intLoop + 1, 2) = strFolderName
        Worksheets("Artik").Cells(intLoop + 1, 3) = strPath
    Next intLoop


    Set WSHShell = Nothing
End Sub




Sub Paul()
    Dim i As Long
   
    With CreateObject("Shell.Application")
        For i = 0 To 99
            Worksheets("Paul").Cells(i + 1, 1) = i
            On Error Resume Next
            Worksheets("Paul").Cells(i + 1, 2) = .Namespace(CVar(i)).Self
            Worksheets("Paul").Cells(i + 1, 3) = .Namespace(CVar(i)).Self.Path
            On Error GoTo 0
        Next i
    End With
End Sub


Sub snb()
    Dim it As Variant
    Dim i As Long
   
    i = 0
   
    For Each it In CreateObject("wscript.shell").specialfolders
      Worksheets("snb").Cells(i + 1, 1) = i
      Worksheets("snb").Cells(i + 1, 2) = CreateObject("scripting.filesystemobject").getfolder(it).Name
      Worksheets("snb").Cells(i + 1, 3) = it
      i = i + 1
    Next
End Sub

---