Retrieve Unique Tag Metadata from a folder and its subfolders

[Luthius]

Guys
I would like your support on how to retrieve all TAG metadata from files that are saved on some folder including its subfolders.
The idea is list all Tag Metadata as unique values in a txt file. Unique because it can be repeatable due the loop will check on different files.
Below an example using Shell to "access" the file properties.

Sub DebugTagMetadata()
'Dim vrFile As Variant

Dim vrFile As Variant
Dim objShell: Set objShell = CreateObject("Shell.Application")

Dim objDirectory:   Set objDirectory = objShell.Namespace("C:\MY FOLDER\")

For Each vrFile In objDirectory.Items
   If Len(Trim(objDirectory.GetDetailsOf(vrFile, 18))) > 0 Then
    Debug.Print objDirectory.GetDetailsOf(vrFile, 18)
    Else
   End If
Next

 

[Luthius]

After several tests I could get some result. The problem now is how to preserve the values of my Array.
Is there a reliable way to identify if the array is empty or not? I tried
the function IsEmpty() but it doesnt work in my code.
Other thing is how to speedup the code below. It is taking too much time to check 10k Files.

[COLOR=#0000ff]Public Const[/COLOR] FolderPath [COLOR=#0000ff]As String[/COLOR] = "D:\Temp\Photos"
[COLOR=#0000ff]Dim[/COLOR] EmptyArray [COLOR=#0000ff]As Boolean  [/COLOR]                   
[COLOR=#0000ff]Dim[/COLOR] arr() [COLOR=#0000ff]As Variant[/COLOR]


[COLOR=#0000ff]Sub[/COLOR] TestingTheCode()
    [COLOR=#0000ff]Dim[/COLOR] objShell
    [COLOR=#0000ff]Set[/COLOR] fso = CreateObject("Scripting.Filesystemobject")
    
    EmptyArray = [COLOR=#0000ff]False[/COLOR]
    SearchForTags fso.GetFolder(FolderPath)
    MsgBox "Done"
[COLOR=#0000ff]End Sub[/COLOR]


[COLOR=#0000ff]Public Function [/COLOR]SearchForTags(MyFolderName) [COLOR=#0000ff]As Variant[/COLOR]
  [COLOR=#0000ff]  Set[/COLOR] objShell = CreateObject("Shell.Application")
   [COLOR=#0000ff] Set[/COLOR] objDirectory = objShell.Namespace(Trim(MyFolderName))
    
[COLOR=#008000]    ' I tried different approachs to verify if my Array (arr) is empty
    ' No success at all. The ideia is when starts the recursivity, I want the code preserving
    ' the values of my array.[/COLOR]
    [COLOR=#0000ff]If Not[/COLOR] (EmptyArray) [COLOR=#0000ff]Then[/COLOR]
        [COLOR=#0000ff]ReDim Preserve[/COLOR] arr(0)
 [COLOR=#0000ff]   Else
        ReDim Preserve [/COLOR]arr([COLOR=#0000ff]UBound[/COLOR](arr) + 1)
  [COLOR=#0000ff]  End If[/COLOR]
    
    [COLOR=#0000ff]For Each[/COLOR] File [COLOR=#0000ff]In [/COLOR]objDirectory.Items
        [COLOR=#0000ff]ReDim Preserve [/COLOR]arr([COLOR=#0000ff]UBound[/COLOR](arr) + 1)
       [COLOR=#0000ff] If[/COLOR] Len(Trim(objDirectory.GetDetailsOf(File, 18))) > 0 [COLOR=#0000ff]Then[/COLOR]
            arr([COLOR=#0000ff]UBound[/COLOR](arr)) = objDirectory.GetDetailsOf(File, 18)
[COLOR=#0000ff]        Else
        End If
    Next[/COLOR]
    
    [COLOR=#0000ff]For Each[/COLOR] SubFolder [COLOR=#0000ff]In [/COLOR]MyFolderName.SubFolders
        EmptyArray = ([COLOR=#0000ff]UBound[/COLOR](arr) > 0)
        SearchForTags SubFolder
  [COLOR=#0000ff]  Next[/COLOR]
[COLOR=#0000ff]End Function[/COLOR]

 

[John_w]

To answer your question with your current code, declare a (global) variable which stores the number of items currently in the array:

Dim n As Long

Initialise it to zero, meaning no items in the array (empty):

n = 0

add an item to the array like this:

        [COLOR=#0000ff]ReDim Preserve [/COLOR]arr([COLOR=#0000ff]n[/COLOR])
       [COLOR=#0000ff] If[/COLOR] Len(Trim(objDirectory.GetDetailsOf(File, 18))) > 0 [COLOR=#0000ff]Then[/COLOR]
            arr(n) = objDirectory.GetDetailsOf(File, 18)
            n = n + 1
[COLOR=#0000ff]        End If
[/COLOR]

and now you don't need to bother with UBound or 'is the array empty' tricks. Alternatively, consider using a Collection or Dictionary and then you don't need ReDim Preserve the array, which is slow.

Recursively looping through a folder structure with FileSystemObject is also slow. Instead, you can run a DOS DIR command from VBA to get a list of all files into an array and loop through the array - there should be example code on the forum.

 

[Luthius]

Thank you. First problem Solved.

The problem now is how to make the code run faster.
There are in average 10k files. It is not a huge amount of data to deal with, but using my approaching with Array is taking ages to verify all folders and files.
I dont know, maybe the Shell Object is slowing the code. I'm not sure.
Is there a way to speed up this?

 

[Luthius]

Instead, you can run a DOS DIR command from VBA to get a list of all files into an array and loop through the array - there should be example code on the forum.

I followed your advice and changed my code to get the file address by DIR command.
My problem now is how to dynamically put the result of the file address in my variable "File" using a loop after I retrieve all the files inside an array?!

Set objDirectory = objShell.Namespace(File)

Dim Arr As Variant

Sub TestFunction()
Dim colFiles As New Collection
Dim FolderPath As String


FolderPath= "D:\Temp\Photos"
ReDim Preserve Arr(0)


RecursiveDir colFiles, FolderPath, "*.jpg", True


Dim objShell: Set objShell = CreateObject("Shell.Application")
Dim objDirectory
Dim File As Variant


For Each File In colFiles
[COLOR=#ff0000]'I'm getting Error here - I cannot dynamically refer the namespace[/COLOR]
    Set objDirectory = objShell.Namespace(File)
    ReDim Preserve Arr(UBound(Arr) + 1)
    If Len(Trim(objDirectory.GetDetailsOf(vrFile, 18))) > 0 Then
        Arr(UBound(Arr)) = objDirectory.GetDetailsOf(vrFile, 18)
    Else
    End If
Next File
End Sub


Public Function RecursiveDir(colFiles As Collection, _
                         strFolder As String, _
                         strFileSpec As String, _
                         bIncludeSubfolders As Boolean)


Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant


'Add files in strFolder matching strFileSpec to colFiles
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
    colFiles.Add strFolder & strTemp
    strTemp = Dir
Loop


If bIncludeSubfolders Then
    'Fill colFolders with list of subdirectories of strFolder
    strTemp = Dir(strFolder, vbDirectory)
    Do While strTemp <> vbNullString
        If (strTemp <> ".") And (strTemp <> "..") Then
            If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                colFolders.Add strTemp
            End If
        End If
        strTemp = Dir
    Loop


    'Call RecursiveDir for each subfolder in colFolders
    For Each vFolderName In colFolders
        Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
    Next vFolderName
End If


End Function


Public Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
    If Right(strFolder, 1) = "\" Then
        TrailingSlash = strFolder
    Else
        TrailingSlash = strFolder & "\"
    End If
 End If
End Function

 

[Luthius]

Any idea on how to solve this problem on code Set objDirectory = objShell.Namespace(File) ?

 

[John_w]

Your previous code doesn't implement a DOS DIR command, but a VBA Dir function loop.

This code implements a DOS DIR command and puts the full paths and file names and item value (the '18' property) in column B of the active sheet:

Public Sub Files_Get_Tags()

    Dim startFolderPath As String
    Dim DIRcommand As String
    Dim files As Variant
    Dim i As Long, p As Long
    Dim Sh32 As Object 'Shell32.Shell
    Dim Sh32Folder As Object 'Shell32.Folder
    Dim folderPath As String
    Dim itemValue As String

    startFolderPath = "D:\Temp\Photos"
        
    'DIR command: not directories, not hidden files, bare format, search subfolders
    
    DIRcommand = "DIR /A-D-H /B /S """ & startFolderPath & """"
    files = Split(CreateObject("Wscript.Shell").Exec("cmd /c " & DIRcommand).StdOut.ReadAll, vbCrLf)
    
    Set Sh32 = CreateObject("Shell.Application") 'New Shell32.Shell
    
    folderPath = ""
    For i = 0 To UBound(files) - 1
        p = InStrRev(files(i), "\", -1)
        If Left(files(i), p) <> folderPath Then
            'Folder path has changed
            folderPath = Left(files(i), p)
            Set Sh32Folder = Sh32.Namespace(CVar(folderPath))
        End If
        itemValue = Sh32Folder.GetDetailsOf(Sh32Folder.ParseName(Mid(files(i), p + 1)), 18)
        files(i) = files(i) & " - " & itemValue
    Next
    
    Columns("B").Clear
    Range("B1").Value = "Number of files = " & UBound(files)
    Range("B2").Resize(UBound(files)).Value = Application.Transpose(files)
    
End Sub

The DIR command run is the equivalent of opening a command prompt window and typing:

DIR /A-D-H /B /S "D:\Temp\Photos"

/A-D-H is files whose attributes are not directories and not hidden files
/B is bare format, so that the full folder path and file name is output
/S is recursive search in the specified directory and all subdirectories

Type DIR /? in a command prompt window to display the full help on the DIR command.

 

[Luthius]

Amazing. I tested and it is working fine.
The last question, as the topic says, is possible get unique values?
Once the TAGs are separated by Comma, I was thinking in use the SPLIT(Tag,",") and then try to store the values in another array, checking before store if the TAG exists.
I just need to know a better way to include this unique values

Public Sub Files_Get_Tags()

    Dim startFolderPath As String
    Dim DIRcommand As String
    Dim files As Variant
    Dim i As Long, p As Long
    Dim Sh32 As Object                           'Shell32.Shell
    Dim Sh32Folder As Object                     'Shell32.Folder
    Dim folderPath As String
    Dim itemValue As String
    Dim tmp As Variant
    startFolderPath = "D:\Temp\Photos"
        
    'DIR command: not directories, not hidden files, bare format, search subfolders
    
    DIRcommand = "DIR /A-D-H /B /S """ & startFolderPath & """"
    files = Split(CreateObject("Wscript.Shell").Exec("cmd /c " & DIRcommand).StdOut.ReadAll, vbCrLf)
    
    Set Sh32 = CreateObject("Shell.Application") 'New Shell32.Shell
    
    folderPath = ""
    For i = 0 To UBound(files) - 1
        p = InStrRev(files(i), "\", -1)
        If Left(files(i), p) <> folderPath Then
            'Folder path has changed
            folderPath = Left(files(i), p)
            Set Sh32Folder = Sh32.Namespace(CVar(folderPath))
        End If
        itemValue = Sh32Folder.GetDetailsOf(Sh32Folder.ParseName(Mid(files(i), p + 1)), 18)
        files(i) = itemValue
    Next
[COLOR=#ff0000]    For Each Item In files[/COLOR]
[COLOR=#ff0000]        If Len(Item) > 0 Then[/COLOR]
[COLOR=#ff0000]            tmp = Split(Item, ";")[/COLOR]
[COLOR=#ff0000]            End If[/COLOR]
[COLOR=#ff0000]    Next Item[/COLOR]
    
    Columns("B").Clear
    Range("B1").Value = "Number of files = " & UBound(files)
    Range("B2").Resize(UBound(files)).Value = Application.Transpose(files)
    
End Sub

 

[John_w]

What values are returned by the '18' property? Can you show the output you want the macro to create?

 

[Luthius]

The folder contains photos.
Each photo has Tags and these Tags are common for different photos.
File: Image01.jpg
Tags:Museum, Statue, Louvre

File: Image02.jpg
Tags:Museum, Painting, Louvre, Monalisa

I gave these 02 examples that on 2 different files were attributed Tags and some are common among the files.
The end result will be a list with all Unique Tags (no repetition)

Tag list:
Museum
Statue
Louvre
Painting
Monalisa