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

 

[John_w]

Try this macro:

Public Sub List_Unique_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 tags As String, tagsArray 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
    
    tags = ","
    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)), 1)
        If InStr(1, tags, "," & itemValue & ",", vbTextCompare) = 0 Then tags = tags & itemValue & ","
    Next
    tagsArray = Split(Mid(tags, 2), ",")
    
    Columns("B").Clear
    Range("B1").Value = "Tag List " & UBound(tagsArray)
    Range("B2").Resize(UBound(tagsArray)).Value = Application.Transpose(tagsArray)
    
End Sub

 

[John_w]

Correction:

        itemValue = Sh32Folder.GetDetailsOf(Sh32Folder.ParseName(Mid(files(i), p + 1)), [B]18[/B])

 

[Luthius]

Thanks but unfortunately is not working.
The TAGs are coming just like before with repetitions, like your previous code. The idea now is get them without the repetitions.
Thanks anyway.

 

[Luthius]

I decided to use Dictionary to get unique values. I added the TRIM() function to clean the Tags as well.
Below your code with Dictionary and other changes
Thank you for all your time and efforts to help me. I really appreciate that.

Public Sub List_Unique_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 tags As String, tagsArray As Variant
    Dim Dictionary As Object
    Dim vrItem As Variant
    
    startFolderPath =[COLOR=#333333]"D:\Temp\Photos"[/COLOR]
        
    '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
    
    tags = ","
    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)
        If Len(Trim(itemValue)) > 0 Then
            If InStr(1, tags, "," & itemValue & ",", vbTextCompare) = 0 Then tags = tags & itemValue & ","
        End If
        
    Next
    tagsArray = Split(Mid(tags, 2), ",")
    
    Set Dictionary = CreateObject("Scripting.Dictionary")
    
    
    For Each vrItem In tagsArray
        If Not Dictionary.exists(Trim(vrItem)) Then
            Dictionary.Add Trim(vrItem), Trim(vrItem)


        End If


    Next vrItem
    
    Columns("B").Clear
    Range("B1").Value = "Tag List " & UBound(Dictionary.keys)
    Range("B2").Resize(UBound(Dictionary.keys)).Value = Application.Transpose(Dictionary.keys)
    
End Sub