Selective listing of files in a folder

I stored the parent folder name into Z1. Change as you like.

This should be close. Tweak to suit. I used your functions and sub naming conventions. The subject routine may need a tweak.

I broke Main() into your two subs.

Code:

---

Sub File_Attributes()   
  Dim SourceFolderName As String
   
    'Get and save the Source Folder Name:
    SourceFolderName = Range("Z1").Value2
    SourceFolderName = "d:\myfiles\excel\t\t\"
    SourceFolderName = fGetFolder("Pick Parent Folder", SourceFolderName)
    If SourceFolderName = "" Then Exit Sub
    If Right(SourceFolderName, 1) <> "\" Then _
      SourceFolderName = SourceFolderName & "\"
    Range("Z1").Value2 = SourceFolderName
   
    File_Attributes_List_Files SourceFolderName, True
End Sub


Rem Needs Tools > References > MicroSoft Script Runtime, scrrun.dll
Rem Instructions: http://support.microsoft.com/default.aspx?scid=kb;en-us;186118
Sub File_Attributes_List_Files(SourceFolderName As String, _
  IncludeSubfolders As Boolean)
 
    Dim x() As Variant, y() As Variant, xx As Variant, i As Long
    Dim sLFolder As String, sLBase As String, sLExt As String 'Last
    Dim sCFolder As String, sCBase As String, sCExt As String 'Current
    Dim sLFBE As String, sCFBE As String
    Dim fso As FileSystemObject, r As Range, rL As Long
    Dim SourceFolderPath As String, FileItemName As String
   
    Set fso = New FileSystemObject
   
    'Descending Order by drive\path\filename.ext. Do not list folders.
    x() = aFFs(SourceFolderName, "/O-N /A-D", IncludeSubfolders) 'True, check all subfolders.
    y() = x() 'Make sure that y() can hold all of x() if needed.
 
    'First cell to add hyperlink.
    Set r = Range("C" & Rows.Count).End(xlUp).Offset(1)
 
    sLFolder = ""
    sLBase = ""
    sLExt = ""
    sLFBE = ""
    sCFolder = ""
    sCBase = ""
    sCExt = ""
    sCFBE = ""
    i = 0
   
    With fso
        For Each xx In x()
            sCFolder = .GetParentFolderName(xx)
            sCBase = .GetBaseName(xx)
            sCExt = .GetExtensionName(xx)
            sCFBE = sCFolder & "\" & PrefixBeforeBracket(sCBase) & sCExt
           
            If sCFBE <> sLFBE Then
                i = i + 1
                ReDim Preserve y(i)
                y(i) = xx
               
                'Reset Last data to Current data based on loop checks above
                sLFolder = sCFolder
                sLBase = sCBase
                sLExt = sCExt
                sLFBE = sLFolder & "\" & PrefixBeforeBracket(sLBase) & sLExt
            End If
        Next xx
    End With
   
    'MsgBox Join(y(), vbLf) 'Truncates end of long strings.
    'Debug.Print Join(y, vbLf) 'May truncate from beginning of long string.
    'Add Hyperlinks and file attributes...
    Set r = ActiveCell
    For i = 1 To UBound(y)
        'r.Hyperlinks.Add r, y(i), TextToDisplay:=fso.GetBaseName(y(i))
        With fso
          SourceFolderPath = .GetFile(y(i)).ParentFolder
          FileItemName = .GetFile(y(i)).Name
          Debug.Print SourceFolderPath, FileItemName
        End With
       
        rL = r.Row
        Rows(rL).Insert
        Cells(rL, 2).Formula = _
          Get_File_Attribute_Subject(SourceFolderPath, FileItemName)
        Cells(rL, 3).Formula = _
          Chr(61) & "HYPERLINK(" & Chr(34) & y(i) & _
          Chr(34) & "," & Chr(34) & FileItemName & Chr(34) & ")"
        Cells(rL, 4).Formula = GetFileDataAuthor(SourceFolderPath, FileItemName)
        Cells(rL, 5).Formula = GetFileDataTitle(SourceFolderPath, FileItemName)
    Next i
End Sub

---

Functions Module Code:

Code:

---

Option Explicit

Function fGetFolder(Optional HeaderMsg As String, Optional sInitialFilename As String = "") As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If sInitialFilename = "" Then sInitialFilename = Application.DefaultFilePath
        .InitialFileName = sInitialFilename
        .Title = HeaderMsg
        If .Show = -1 Then
            fGetFolder = .SelectedItems(1)
        Else
            fGetFolder = ""
        End If
    End With
End Function


Function PrefixBeforeBracket(aString As String) As String
    Dim i As Integer
    i = InStr(aString, "[")
    If i = 0 Then
        PrefixBeforeBracket = aString
    Else
        PrefixBeforeBracket = Left(aString, i - 1)
    End If
End Function
 


  'Set extraSwitches, e.g. "/ad", to search folders only.
 'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
 'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
    Optional tfSubFolders As Boolean = False) As Variant
   
    Dim s As String, a() As String, v As Variant
    Dim b() As Variant, i As Long
   
    If tfSubFolders Then
        s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
        """" & myDir & """" & " /b /s " & extraSwitches).StdOut.ReadAll
    Else
        s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
        """" & myDir & """" & " /b " & extraSwitches).StdOut.ReadAll
    End If
   
    a() = Split(s, vbCrLf)
    If UBound(a) = -1 Then
        MsgBox myDir & " not found.", vbCritical, "Macro Ending"
        Exit Function
    End If
    ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr
   
    For i = 0 To UBound(a)
        If Not tfSubFolders Then
            s = Left$(myDir, InStrRev(myDir, "\"))
            'add the folder name
            a(i) = s & a(i)
        End If
    Next i
    aFFs = sA1dtovA1d(a)
End Function


 
Function sA1dtovA1d(strArray() As String) As Variant
    Dim varArray() As Variant, i As Long
    ReDim varArray(LBound(strArray) To UBound(strArray))
    For i = LBound(strArray) To UBound(strArray)
        varArray(i) = CVar(strArray(i))
    Next i
    sA1dtovA1d = varArray()
End Function


Function Get_File_Attribute_Subject(ByVal Filepath As String, ByVal FileName As String)
    Dim objFolder As Object
    Dim objFolderItem As Object
    Dim objShell As Object
    FileName = StrConv(FileName, vbUnicode)
    Filepath = StrConv(Filepath, vbUnicode)
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(StrConv(Filepath, vbFromUnicode))
    If Not objFolder Is Nothing Then
        Set objFolderItem = objFolder.ParseName(StrConv(FileName, vbFromUnicode))
    End If
    If Not objFolderItem Is Nothing Then
        Get_File_Attribute_Subject = objFolder.GetDetailsOf(objFolderItem, 22) '11 (Windows xp), 22 (Windows Vista, Windows 7, Windows 8)
    Else
        Get_File_Attribute_Subject = ""
    End If
    Set objShell = Nothing
    Set objFolder = Nothing
    Set objFolderItem = Nothing
End Function
 
Function GetFileDataAuthor(ByVal Filepath As String, ByVal FileName As String)
    Dim objFolder As Object
    Dim objFolderItem As Object
    Dim objShell As Object
    FileName = StrConv(FileName, vbUnicode)
    Filepath = StrConv(Filepath, vbUnicode)
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(StrConv(Filepath, vbFromUnicode))
    If Not objFolder Is Nothing Then
        Set objFolderItem = objFolder.ParseName(StrConv(FileName, vbFromUnicode))
    End If
    If Not objFolderItem Is Nothing Then
        GetFileDataAuthor = objFolder.GetDetailsOf(objFolderItem, 20) '9 (Windows xp), 20 (Windows Vista, Windows 7, Windows 8)
    Else
        GetFileDataAuthor = ""
    End If
    Set objShell = Nothing
    Set objFolder = Nothing
    Set objFolderItem = Nothing
End Function
 
Function GetFileDataTitle(ByVal Filepath As String, ByVal FileName As String)
    Dim objFolder As Object
    Dim objFolderItem As Object
    Dim objShell As Object
    FileName = StrConv(FileName, vbUnicode)
    Filepath = StrConv(Filepath, vbUnicode)
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(StrConv(Filepath, vbFromUnicode))
    If Not objFolder Is Nothing Then
        Set objFolderItem = objFolder.ParseName(StrConv(FileName, vbFromUnicode))
    End If
    If Not objFolderItem Is Nothing Then
        GetFileDataTitle = objFolder.GetDetailsOf(objFolderItem, 21) '10 (Windows xp), 21 (Windows Vista, Windows 7, Windows 8)
    Else
        GetFileDataTitle = ""
    End If
    Set objShell = Nothing
    Set objFolder = Nothing
    Set objFolderItem = Nothing
End Function




 'script56.chm, http://tinyurl.com/5ts6r8
Sub Test_FSO(aFilename As String)
    Dim oFSO As Object, sFolder As String, sBasename As String
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    sFolder = oFSO.GetFile(aFilename).ParentFolder
    sBasename = oFSO.GetBaseName(aFilename)
   
Option Explicit


Function fGetFolder(Optional HeaderMsg As String, Optional sInitialFilename As String = "") As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If sInitialFilename = "" Then sInitialFilename = Application.DefaultFilePath
        .InitialFileName = sInitialFilename
        .Title = HeaderMsg
        If .Show = -1 Then
            fGetFolder = .SelectedItems(1)
        Else
            fGetFolder = ""
        End If
    End With
End Function


Function PrefixBeforeBracket(aString As String) As String
    Dim i As Integer
    i = InStr(aString, "[")
    If i = 0 Then
        PrefixBeforeBracket = aString
    Else
        PrefixBeforeBracket = Left(aString, i - 1)
    End If
End Function
 


  'Set extraSwitches, e.g. "/ad", to search folders only.
 'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
 'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
    Optional tfSubFolders As Boolean = False) As Variant
   
    Dim s As String, a() As String, v As Variant
    Dim b() As Variant, i As Long
   
    If tfSubFolders Then
        s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
        """" & myDir & """" & " /b /s " & extraSwitches).StdOut.ReadAll
    Else
        s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
        """" & myDir & """" & " /b " & extraSwitches).StdOut.ReadAll
    End If
   
    a() = Split(s, vbCrLf)
    If UBound(a) = -1 Then
        MsgBox myDir & " not found.", vbCritical, "Macro Ending"
        Exit Function
    End If
    ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr
   
    For i = 0 To UBound(a)
        If Not tfSubFolders Then
            s = Left$(myDir, InStrRev(myDir, "\"))
            'add the folder name
            a(i) = s & a(i)
        End If
    Next i
    aFFs = sA1dtovA1d(a)
End Function


 
Function sA1dtovA1d(strArray() As String) As Variant
    Dim varArray() As Variant, i As Long
    ReDim varArray(LBound(strArray) To UBound(strArray))
    For i = LBound(strArray) To UBound(strArray)
        varArray(i) = CVar(strArray(i))
    Next i
    sA1dtovA1d = varArray()
End Function


Function Get_File_Attribute_Subject(ByVal Filepath As String, ByVal FileName As String)
    Dim objFolder As Object
    Dim objFolderItem As Object
    Dim objShell As Object
    FileName = StrConv(FileName, vbUnicode)
    Filepath = StrConv(Filepath, vbUnicode)
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(StrConv(Filepath, vbFromUnicode))
    If Not objFolder Is Nothing Then
        Set objFolderItem = objFolder.ParseName(StrConv(FileName, vbFromUnicode))
    End If
    If Not objFolderItem Is Nothing Then
        Get_File_Attribute_Subject = objFolder.GetDetailsOf(objFolderItem, 22) '11 (Windows xp), 22 (Windows Vista, Windows 7, Windows 8)
    Else
        Get_File_Attribute_Subject = ""
    End If
    Set objShell = Nothing
    Set objFolder = Nothing
    Set objFolderItem = Nothing
End Function
 
Function GetFileDataAuthor(ByVal Filepath As String, ByVal FileName As String)
    Dim objFolder As Object
    Dim objFolderItem As Object
    Dim objShell As Object
    FileName = StrConv(FileName, vbUnicode)
    Filepath = StrConv(Filepath, vbUnicode)
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(StrConv(Filepath, vbFromUnicode))
    If Not objFolder Is Nothing Then
        Set objFolderItem = objFolder.ParseName(StrConv(FileName, vbFromUnicode))
    End If
    If Not objFolderItem Is Nothing Then
        GetFileDataAuthor = objFolder.GetDetailsOf(objFolderItem, 20) '9 (Windows xp), 20 (Windows Vista, Windows 7, Windows 8)
    Else
        GetFileDataAuthor = ""
    End If
    Set objShell = Nothing
    Set objFolder = Nothing
    Set objFolderItem = Nothing
End Function
 
Function GetFileDataTitle(ByVal Filepath As String, ByVal FileName As String)
    Dim objFolder As Object
    Dim objFolderItem As Object
    Dim objShell As Object
    FileName = StrConv(FileName, vbUnicode)
    Filepath = StrConv(Filepath, vbUnicode)
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(StrConv(Filepath, vbFromUnicode))
    If Not objFolder Is Nothing Then
        Set objFolderItem = objFolder.ParseName(StrConv(FileName, vbFromUnicode))
    End If
    If Not objFolderItem Is Nothing Then
        GetFileDataTitle = objFolder.GetDetailsOf(objFolderItem, 21) '10 (Windows xp), 21 (Windows Vista, Windows 7, Windows 8)
    Else
        GetFileDataTitle = ""
    End If
    Set objShell = Nothing
    Set objFolder = Nothing
    Set objFolderItem = Nothing
End Function

---

Kenneth
Thanks once again, it all works and is much more comprehensive now, except I can't progress with "the folder dialogue remembering the last location". Not sure how to define the parameters but the initial code had a memory at least until I rebooted my computer, and it only needs to work for this workbook.
I will make a donation to the forum for your assistance as I have been trying to work through this mini-project for a few months on and off.
Kind regards.

You should delete this line out. It was used for testing. By poking the value into a Cell, Z1 in this case, it will always "remember" the last path.

Code:

---

SourceFolderName = "d:\myfiles\excel\t\t\"

---

Thx.
All the best.

Kenneth
I'm stretching this post but sorry I can only ask.
I've been listing all my documents into one spreadsheet and it's working as intended. But is there any way to resolve any of the items listed. If it's too involved then please say so.
5. Would it be possible to use the default order rather than reverse order (O:N with last file picked, rather than O-N with first file picked)?
6. Is it possible to differentiate between alpha and numeric revisions, in order to have two outputs. As an example an output of "File [C]" and "File [2]" would come from File [A], File [B], File [C], File [1], File [2].
7. For numeric cases, sometimes I have double digit revisions, and this isn't selected because the leading digit is smaller. Example, File [9] is selected instead of File [10].
I'm willing to donate further or if someone can send me a quote to do the work I can look at that.

@KH

Code:

---

sub M_snb()
  sp=F_aFFs("G:\OF\*.png")
  if ubound(sp)=-1 then msgbox "no files found"
end sub

Function F_aFFs(myDir As String, Optional extraSwitches = "", Optional tfSubFolders As Boolean = False) As Variant
  F_aFFs = Split(CreateObject("Wscript.Shell").Exec("cmd /c dir """ & myDir & """ /b " & IIf(tfSubFolders, "/s ", "") & extraSwitches).StdOut.ReadAll, vbCrLf)
   
  If Not tfSubFolders And UBound(F_aFFs) > -1 Then F_aFFs = Split(Replace(Join(vbLf & F_aFFs, vbCrLf), vbLf, left(myDir,instrrev(mydir,"\")), vbCr)
End Function

---

I will test that snb, thanks!

Trying, click the Consulting Services link in the middle top of this forum.

I doubt that I will get a block of time to work on this much. Your naming convention rules are not consistent so it makes doing this more difficult. It is not clear if File [A] or File [1] is chosen as the "last" version. What would the "last version" be if these occur: File, File A, File 1, File [A1], File [1A], File [AA]? Of course there could be a case where version 2 was the last created but version 1 was the last modified.

Versions is why Microsoft has a convention for doing that. I have a kb article here where I made it easy to use Microsoft's API method(s). http://www.vbaexpress.com/kb/getarticle.php?kb_id=1041

Kenneth
I can see how this is so complicated. Most of the above examples can occur in reality as well. More confusing is that some clients have different conventions, [A1] may be later than [AA] or it may be the other way around. I will use the Consulting services to get a quote for this.
Before being made aware of the above, I only had in mind alpha or numeric revisions used exclusively. And I would need two outputs, both File [A] and File [1]. If it's too complex I would just leave it.
Filenames without square brackets would not exist.
Revisions are based on filenames only and not modified attributes from Windows.
Kind regards.

@Trying

The problem isn't that it would be 'too complex'.
The problem is that there's no pattern; you can't search for a pattern that isn't present.

There are patterns there, just too many. Every client has their own.

Possible kludge: Open file, Select Case owner, send file and pattern details to next procedure.

This would require a list of Companies and or Authors and their patterns.

Trying, you have a systemic issue that requires a systemic solution. Such solution could include steps intermediate to receiving and saving that assign specific values to file Properties. By "Systemic," I mean entire business wide systems.

With the code at Item #21, the files are listed in descending order with the first file picked. Is it possible to list in ascending order with the last file picked?
Or can the output be taken and be sorted in a separate routine?

Yes and Yes though ORDER is SORT. That is why I posted the link for DIR command parameter help. 'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html

Kenneth, notwithstanding the above issue I have to go back a step.
I noticed that for files with different extensions all of the files are written into Excel. As an example, for the list below all files are shown, rather than only SPEC 007-M-0002 [11].docx and SPEC 007-M-0002 [11].pdf.

SPEC 007-M-0002 [11].pdf
SPEC 007-M-0002 [11].docx
SPEC 007-M-0002 [10].pdf
SPEC 007-M-0002 [10].docx

Tried to add another function "PrefixAfterBracket" to be used with "PrefixBeforeBracket" but no luck.

Current code:

Code:

---

Sub File_Attributes()
    Dim sFolder As FileDialog
   
    Set sFolder = Application.FileDialog(msoFileDialogFolderPicker)
   
    If sFolder.Show = -1 Then
        File_Attributes_List_Files sFolder.SelectedItems(1), True
    End If
End Sub
 
 
Rem Needs Tools > References > Microsoft Scripting Runtime, scrrun.dll
Rem Instructions: http://support.microsoft.com/default.aspx?scid=kb;en-us;186118
Sub File_Attributes_List_Files(SourceFolderName As String, _
    IncludeSubfolders As Boolean)
   
    Dim x() As Variant, y() As Variant, xx As Variant, i As Long
    Dim sLFolder As String, sLBase As String, sLExt As String 'Last
    Dim sCFolder As String, sCBase As String, sCExt As String 'Current
    Dim sLFBE As String, sCFBE As String
    Dim fso As FileSystemObject, r As Range, rL As Long
    Dim SourceFolderPath As String, FileItemName As String
   
    Set fso = New FileSystemObject
   
    'Descending Order by drive\path\filename.ext. Do not list folders.
    x() = aFFs(SourceFolderName, "/O-N /A-D", IncludeSubfolders) 'True, check all subfolders.
    y() = x() 'Make sure that y() can hold all of x() if needed.
   
    'First cell to add hyperlink.
    Set r = Range("C" & Rows.Count).End(xlUp).Offset(1)
   
    sLFolder = ""
    sLBase = ""
    sLExt = ""
    sLFBE = ""
    sCFolder = ""
    sCBase = ""
    sCExt = ""
    sCFBE = ""
    i = 0
   
    With fso
        For Each xx In x()
            sCFolder = .GetParentFolderName(xx)
            sCBase = .GetBaseName(xx)
            sCExt = .GetExtensionName(xx)
            sCFBE = sCFolder & "\" & PrefixBeforeBracket(sCBase) & sCExt
           
            If sCFBE <> sLFBE Then
                i = i + 1
                ReDim Preserve y(i)
                y(i) = xx
               
                'Reset Last data to Current data based on loop checks above
                sLFolder = sCFolder
                sLBase = sCBase
                sLExt = sCExt
                sLFBE = sLFolder & "\" & PrefixBeforeBracket(sLBase) & sLExt
            End If
        Next xx
    End With
   
    'MsgBox Join(y(), vbLf) 'Truncates end of long strings.
    'Debug.Print Join(y, vbLf) 'May truncate from beginning of long string.
    'Add Hyperlinks and file attributes...
    Set r = ActiveCell
    For i = 1 To UBound(y)
        'r.Hyperlinks.Add r, y(i), TextToDisplay:=fso.GetBaseName(y(i))
        With fso
            SourceFolderPath = .GetFile(y(i)).ParentFolder
            FileItemName = .GetFile(y(i)).Name
            Debug.Print SourceFolderPath, FileItemName
        End With
       
        rL = r.Row
        Rows(rL).Insert
        Cells(rL, 2).Formula = _
        Get_File_Attribute_Subject(SourceFolderPath, FileItemName)
        Cells(rL, 3).Formula = _
        Chr(61) & "HYPERLINK(" & Chr(34) & y(i) & _
        Chr(34) & "," & Chr(34) & FileItemName & Chr(34) & ")"
        Cells(rL, 4).Formula = GetFileDataAuthor(SourceFolderPath, FileItemName)
        Cells(rL, 5).Formula = GetFileDataTitle(SourceFolderPath, FileItemName)
    Next i
End Sub

---

Functions:

Code:

---

Option Explicit

Function PrefixBeforeBracket(aString As String) As String
    Dim i As Integer
    i = InStr(aString, "[")
    If i = 0 Then
        PrefixBeforeBracket = aString
    Else
        PrefixBeforeBracket = Left(aString, i - 1)
    End If
End Function
   
'Set extraSwitches, e.g. "/ad", to search folders only.
'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
    Optional tfSubFolders As Boolean = False) As Variant

    Dim s As String, a() As String, v As Variant
    Dim b() As Variant, i As Long

    If tfSubFolders Then
        s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
        """" & myDir & """" & " /b /s " & extraSwitches).StdOut.ReadAll
    Else
        s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
        """" & myDir & """" & " /b " & extraSwitches).StdOut.ReadAll
    End If

    a() = Split(s, vbCrLf)
    If UBound(a) = -1 Then
        MsgBox myDir & " not found.", vbCritical, "Macro Ending"
        Exit Function
    End If
    ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr

    For i = 0 To UBound(a)
        If Not tfSubFolders Then
            s = Left$(myDir, InStrRev(myDir, "\"))
            'add the folder name
            a(i) = s & a(i)
        End If
    Next i
    aFFs = sA1dtovA1d(a)
End Function

Function sA1dtovA1d(strArray() As String) As Variant
    Dim varArray() As Variant, i As Long
    ReDim varArray(LBound(strArray) To UBound(strArray))
    For i = LBound(strArray) To UBound(strArray)
        varArray(i) = CVar(strArray(i))
    Next i
    sA1dtovA1d = varArray()
End Function

Function Get_File_Attribute_Subject(ByVal Filepath As String, ByVal FileName As String)
    Dim objFolder As Object
    Dim objFolderItem As Object
    Dim objShell As Object
    FileName = StrConv(FileName, vbUnicode)
    Filepath = StrConv(Filepath, vbUnicode)
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(StrConv(Filepath, vbFromUnicode))
    If Not objFolder Is Nothing Then
        Set objFolderItem = objFolder.ParseName(StrConv(FileName, vbFromUnicode))
    End If
    If Not objFolderItem Is Nothing Then
        Get_File_Attribute_Subject = objFolder.GetDetailsOf(objFolderItem, 22) '11 (Windows xp), 22 (Windows Vista, Windows 7, Windows 8)
    Else
        Get_File_Attribute_Subject = ""
    End If
    Set objShell = Nothing
    Set objFolder = Nothing
    Set objFolderItem = Nothing
End Function

Function GetFileDataAuthor(ByVal Filepath As String, ByVal FileName As String)
    Dim objFolder As Object
    Dim objFolderItem As Object
    Dim objShell As Object
    FileName = StrConv(FileName, vbUnicode)
    Filepath = StrConv(Filepath, vbUnicode)
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(StrConv(Filepath, vbFromUnicode))
    If Not objFolder Is Nothing Then
        Set objFolderItem = objFolder.ParseName(StrConv(FileName, vbFromUnicode))
    End If
    If Not objFolderItem Is Nothing Then
        GetFileDataAuthor = objFolder.GetDetailsOf(objFolderItem, 20) '9 (Windows xp), 20 (Windows Vista, Windows 7, Windows 8)
    Else
        GetFileDataAuthor = ""
    End If
    Set objShell = Nothing
    Set objFolder = Nothing
    Set objFolderItem = Nothing
End Function

Function GetFileDataTitle(ByVal Filepath As String, ByVal FileName As String)
    Dim objFolder As Object
    Dim objFolderItem As Object
    Dim objShell As Object
    FileName = StrConv(FileName, vbUnicode)
    Filepath = StrConv(Filepath, vbUnicode)
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(StrConv(Filepath, vbFromUnicode))
    If Not objFolder Is Nothing Then
        Set objFolderItem = objFolder.ParseName(StrConv(FileName, vbFromUnicode))
    End If
    If Not objFolderItem Is Nothing Then
        GetFileDataTitle = objFolder.GetDetailsOf(objFolderItem, 21) '10 (Windows xp), 21 (Windows Vista, Windows 7, Windows 8)
    Else
        GetFileDataTitle = ""
    End If
    Set objShell = Nothing
    Set objFolder = Nothing
    Set objFolderItem = Nothing
End Function

---