PDA

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


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
snb
10-21-2021, 01:11 AM
Are you trying to rebuild the explorer ?
Paul_Hossler
10-21-2021, 09:04 AM
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




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
rlsbb1223
10-21-2021, 05:19 PM
Thanks for the reply Paul.

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


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
Paul_Hossler
10-21-2021, 06:20 PM
I don't know what INSERTFOLDER is

This works




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
snb
10-22-2021, 01:02 AM
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:


MsgBox CreateObject("wscript.shell").specialfolders(10)
Artik
10-23-2021, 04:07 PM
By the way.


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

Artik
Paul_Hossler
10-23-2021, 09:18 PM
Using Windows 10, the easiest way I know to get the special folder enums is



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


29083
snb
10-24-2021, 02:24 AM
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.
Artik
10-24-2021, 02:36 AM
This post is more directed towards Paul.

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

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
snb
10-24-2021, 09:41 AM
@Artik


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
Paul_Hossler
10-24-2021, 10:21 AM
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




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