Consulting

Results 1 to 12 of 12

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

  1. #1

    Is there a faster method to find extended file properties

    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
    Last edited by rlsbb1223; 10-20-2021 at 09:47 PM.

  2. #2
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,267
    Are you trying to rebuild the explorer ?

  3. #3
    VBAX Sage
    Joined
    Apr 2007
    Posts
    8,040
    Location
    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
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  4. #4
    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

  5. #5
    VBAX Sage
    Joined
    Apr 2007
    Posts
    8,040
    Location
    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
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  6. #6
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,267
    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)
    Last edited by snb; 10-22-2021 at 01:21 AM.

  7. #7
    VBAX Mentor
    Joined
    Dec 2008
    Posts
    390
    Location
    By the way.


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

    Artik

  8. #8
    VBAX Sage
    Joined
    Apr 2007
    Posts
    8,040
    Location
    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
    Capture.JPG
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  9. #9
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,267
    Quote Originally Posted by Artik View Post
    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.

  10. #10
    VBAX Mentor
    Joined
    Dec 2008
    Posts
    390
    Location
    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

  11. #11
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,267
    @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

  12. #12
    VBAX Sage
    Joined
    Apr 2007
    Posts
    8,040
    Location
    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
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •