Selective listing of files in a folder

The following macro selects a folder and lists all files in that folder. It works as intended.
For each document there are several revisions, and I want to only list the last revision (see below). Some files have alpha revisions, some have numeric revisions.
This has been posted in another forum but no response so far.

WHAT IS HAPPENING
FileOne [A]
FileOne [B]
FileOne [C]
FileTwo [0]
FileTwo [1]
FileTwo [2]

WHAT I WANT
FileOne [C]
FileTwo [2]

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

Sub File_Attributes_List_Files(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean)
    Dim FSO As Object
    Dim SourceFolder As Object
    Dim SubFolder As Object
    Dim FileItem As Object
    Dim r As Long

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.GetFolder(SourceFolderName)

    r = ActiveCell.Row
    For Each FileItem In SourceFolder.Files
    Rows(r).Insert
    Cells(r, 3).Formula = Chr(61) & "HYPERLINK(" & Chr(34) & FileItem.Path & Chr(34) & "," & Chr(34) & FileItem.Name & Chr(34) & ")"
    r = r + 1
    x = SourceFolder.Path
    Next FileItem

    If IncludeSubfolders Then
    For Each SubFolder In SourceFolder.SubFolders
    File_Attributes_List_Files SubFolder.Path, True
    Next SubFolder
    End If

    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
    ActiveWorkbook.Saved = True
End Sub

---

My main computer is down and all I have is this old laptop, but. . .

Only a suggestion for your consideration.Soory I can do no better ATT.

After

Code:

---

    Set SourceFolder = FSO.GetFolder(SourceFolderName)

---

add

Code:

---

Dim AllFiles(1 to SourceFolder.Count)
For i = 1 to SourceFolder.Count
AllFiles(i) = SourceFolder.Items(i)
Next

---

then sort the array allFiles.

Then loop thru the sorted array looking for the last of each similar file name

Code:

---

Dim BPos as Long
For i = 1 to UBound(AllFiles)
Fname = AllFiles(i)
BPos = InStr(Fname, "[") - 1
Fname = Left(Fname, BPos)

Do While InStr(AllFiles(i + 1), FName)
i = i + 1
Loop

      Rows(r).Insert
        Cells(r, 3).Formula = Chr(61) & "HYPERLINK(" & Chr(34) & SourceFolder.Items(i).Path & Chr(34) & "," & Chr(34) & SourceFolder.Items(i).Name & Chr(34) & ")"

'Etc etc Etc
Loop

---

Incorporating subfolders is a different subject.

I get an error message: "Compile error: Constant expression required".
.Count is highlighted in the line: "Dim AllFiles(1 To SourceFolder.Count)".

Sorry, all my reference files on the broken computer.

Not to worry, somebody else will be along shortly.

I guess you are wanting the last version based on filename and not last revision to the file? Windows has a file attribute with created and modified dates.

If you want the former, then I would probably reverse (descending) sort the filenames and use Split(), Join() and Ubound(). For the sorting routine, if all files would have the same file extension, coding would be a bit less. e.g. No XLSX, XLSM, and XLS files with the same basename.

This is why most use a common file naming convention to avoid those issues. I wrote a kb article with code to show how to save files using Windows unique filenaming convention. http://www.vbaexpress.com/kb/getarticle.php?kb_id=1041

As a start, rather than using FSO, I would just get the file list and reverse sort as I explained in #17 of http://www.vbaexpress.com/forum/showthread.php?54971
From there, you can check if the first one is the last version named one. My test in that thread shows how to quick view the array.

Kenneth, the code in thread above (#17) lists all the files. How can I make it list only one version as per original question. Am I missing something?<br>

I solve problems one step at a time. The first step that I would do is to get all the filenames into an array in descending order. Try doing that and see if that works first.

One then needs to consider the next steps. In your example, you show two words in the base filename with the 2nd having []'s around them. Knowing that, we can then create a loop to create another array with the filenames needed. Of course if one word base filename exists, then that is another consideration.

to retrieve the last version of file 'example.xlsx' in directory 'G:\OF'

Code:

---

Sub M_snb()
  msgbox split(createobject("wscript.shell").exec("cmd /c dir ""G:\OF\example*.xlsx"" /b/s/o-d").stdout.readall,vbcrlf)(0)
End Sub

---

Yes the code sorts in descending order. But I can't progress with the next part as my VB skills are only just past beginner. Meaning I need an explicit code example. With respect to file names, they could be all variations, single word, multiple words, dashes, dots, etc. Revisions could be alpha or numeric.

1. Do you only want to search within a single folder, i.e. not looking in sub folders?

2. If you do want to search the entire tree, how do you want to handle something like

...\Folder1\Filename[1]
...\Folder1\Filename[2]
...\Folder2\Filename[1]
...\Folder3\Filename[3]

Just return ...\Folder3\Filename[3]?


3. If you do want to search the entire tree, how do you want to handle something like

...\Folder1\Filename[1]
...\Folder1\Filename[2]
...\Folder2\Filename[1]
...\Folder2\Filename[2]


Return both ...\Folder1\Filename[2] and ...\Folder2\Filename[2]???

1. Prefer folder tree. Single folder acceptable.
2. Cannot understand ... assuming searching one folder only. In Folder 1, return Filename[2].
3. Yes.

Paul asked a good question. Basically, it looks like you base last versions on each subfolder's last version.

I guess you got this far. I don't have time to finish this right now but it shows how I would set it up. You have to look at the last and current, folder, base filename, and file extension.

Code:

---

Rem Needs Tools > References > MicroSoft Script Runtime, scrrun.dll
Rem Instructions: http://support.microsoft.com/default.aspx?scid=kb;en-us;186118
Sub Main()
  Dim sParent As String, x() As Variant, xx As Variant
  Dim sLFolder As String, sLBase As String, sLExt As String 'Last
  Dim sCFolder As String, sCBase As String, sCExt As String 'Current
  Dim fso As FileSystemObject
  Dim s() As String
 
  Set fso = New FileSystemObject
 
  sParent = "x:\t\tt\ttt"
  sParent = fGetFolder("Delete Selection to Pick Entry Folder", sParent)
  If sParent = "" Then Exit Sub
   
  'Descending Order by drive\path\filename.ext. Do not list folders.
  x() = aFFs("x:\t\tt", "/O-N /A-D", True) 'True, check all subfolders.
  'MsgBox Join(x(), vbLf) 'Truncates end of long strings.
  'Debug.Print Join(x, vbLf) 'May truncate from beginning of long string.


  sLFolder = ""
  sLBase = ""
  sLExt = ""
  sCFolder = ""
  sCBase = ""
  sCExt = ""


  With fso
    For Each xx In x()
      sCFolder = .GetParentFolderName(xx)
      sCBase = .GetBaseName(xx)
      sCExt = .GetExtensionName(xx)
     
      'Do checks here, show debug results for testing purposes.
'MAIN VERSION CHECKS USING LAST and CURRENT DATA, GO BELOW....
      Debug.Print sLFolder, sLBase, sLExt 'Last results
      Debug.Print sCFolder, sCBase, sCExt 'Current results
     
      'Reset Last data to Current data based on IF checks added above
      sLFolder = sCFolder
      sLBase = sCBase
      sLExt = sCExt
    Next xx
  End With
End Sub


Private 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


'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

---

Quote:

---

Originally Posted by Trying

1. Prefer folder tree. Single folder acceptable.
2. Cannot understand ... assuming searching one folder only. In Folder 1, return Filename[2].
3. Yes.

---

Your answer to 1 (Search entire folder tree) seems to conflict with your answer to 2 (one folder only). In the example/question the [3] file was in a different folder, but still within the over all tree.

a. So if you wanted to search within only each sub folder of each (sub) folder, then you'd have 3 returned


...\Folder1\Filename[1] - No
...\Folder1\Filename[2] - Yes
...\Folder2\Filename[1] - Yes
...\Folder3\Filename[3] - Yes



b. So if you wanted to search the entire folder tree, then you'd have 1 returned


...\Folder1\Filename[1] - No
...\Folder1\Filename[2] - No
...\Folder2\Filename[1] - No
...\Folder3\Filename[3] - Yes

All depends on what your requirements are

@ Trying

Since you apparently have no organization to your files and folders, how do we know which of these files you want returned?

Folder Tree MainFolder
	Folder1
		Folder3
	Folder2
MainFolder Files	Folder1 Files	Folder2 Files	Folder3 Files
FstFile.xls	FstFile.xls	FstFile.xls	FstFile.xls
FstFile[1].xls	FstFile[2].xls	ThrdFile.xls	SecFile.xls
SecFile.xls	SecFile[1].xls	FrthFile.xls	FrthFile[1].xls

Please tell us that there is a rule about where files are stored.

And please tell us that rule.

Paul, this is what I was after.

...\Folder1\Filename[1] - No
...\Folder1\Filename[2] - Yes
...\Folder2\Filename[1] - Yes
...\Folder3\Filename[3] - Yes

Continuing brief: In a folder tree, for each folder (the key), where there are multiple files with the same name but different revision, return only the data for the latest revision file. File revisions are bound by square brackets. Revision tags may be numeric single digit such as [1], numeric multiple digit such as [12], or alpha such as [A].

Kenneth, I get an error message when I run the code.
Compile error: User-defined type not defined.
Highlights "Dim FSO As FileSystemObject"

Rem and ' designate comments. In the REM, I explain that it uses a library reference and how to add it. I also provided a link to the help file for fso.

This should be close.

Code:

---

Option Explicit

Rem Needs Tools > References > MicroSoft Script Runtime, scrrun.dll
Rem Instructions: http://support.microsoft.com/default.aspx?scid=kb;en-us;186118
Sub Main()
  Dim sParent As String, 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
 
  Set fso = New FileSystemObject
 
  sParent = "d:\myfiles\Excel\t\t\" 'Add trailing backslash, "\".
  sParent = fGetFolder("Pick Parent Folder", sParent)
  If sParent = "" Then Exit Sub
   
  'Descending Order by drive\path\filename.ext. Do not list folders.
  x() = aFFs(sParent, "/O-N /A-D", True) 'True, check all subfolders.
  'MsgBox Join(x(), vbLf) 'Truncates end of long strings.
  'Debug.Print Join(x, vbLf) 'May truncate from beginning of long string.


  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...
  For i = 1 To UBound(y)
    r.Hyperlinks.Add r, y(i), TextToDisplay:=fso.GetBaseName(y(i))
    Set r = r.Offset(1)
  Next i
End Sub


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


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


'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

---

Kenneth, this works!
Thx for the effort.

Kenneth, your macro works very well but it is so different to the initial one I was using, and I'm finding it difficult to integrate with the rest of the VB project (not shown initially because I didn't think it was relevant when I posted). The detailed code is shown below. The items which I cannot resolve include the following.
1. In addition to the hyperlink output, I also have others including Subject, Author and Title. These are Windows file attributes. Refer to Code 1.
2. The cell output from the initial code included the hyperlink with the folder path written in. I still need this because I was using another macro to open up Windows Explorer using the cell output (from a right click menu). Refer to Code 2a and 2b.
3. For each iteration I need to add a row into Excel, at the moment doing this by Rows(r).Insert.
4. With the folder dialogue I would like this to remember the last location it was on.
Sorry if this is too much. Whatever you can assist with.


*** Code 1

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

Sub File_Attributes_List_Files(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean)
    Dim FSO As Object
    Dim SourceFolder As Object
    Dim SubFolder As Object
    Dim FileItem As Object
    Dim r As Long
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
    r = ActiveCell.Row
    For Each FileItem In SourceFolder.Files
    Rows(r).Insert
    Cells(r, 2).Formula = Get_File_Attribute_Subject(SourceFolder.Path, FileItem.Name)
    Cells(r, 3).Formula = Chr(61) & "HYPERLINK(" & Chr(34) & FileItem.Path & Chr(34) & "," & Chr(34) & FileItem.Name & Chr(34) & ")"
    Cells(r, 4).Formula = GetFileDataAuthor(SourceFolder.Path, FileItem.Name)
    Cells(r, 5).Formula = GetFileDataTitle(SourceFolder.Path, FileItem.Name)
    r = r + 1
    x = SourceFolder.Path
    Next FileItem
    If IncludeSubfolders Then
    For Each SubFolder In SourceFolder.SubFolders
    File_Attributes_List_Files SubFolder.Path, True
    Next SubFolder
    End If
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
    ActiveWorkbook.Saved = True
End Sub

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

---

*** Code 2a (under Workbook)

Code:

---

Option Explicit

Private Sub Workbook_Activate()
    Run "Hide_Sheet"
    Run "Open_Folder_Create_Menu"
End Sub

---

*** Code 2b

Code:

---

Const strMacro = "Open Explorer"

Sub Open_Folder_Create_Menu()
    Dim cBut
    Call Open_Folder_Remove_Menu
    Set cBut = Application.CommandBars("Cell").Controls.Add(Temporary:=True)
    With cBut
        .Caption = strMacro
        .Style = msoButtonCaption
        .OnAction = "Open_Folder"
    End With
End Sub

Sub Open_Folder_Remove_Menu()
    On Error Resume Next
    Application.CommandBars("Cell").Controls(strMacro).Delete
End Sub

Sub Open_Folder()
    Dim Folder As String
    Folder = Replace(ActiveCell.Formula, "=HYPERLINK(", "")
    Folder = Replace(Left(Folder, InStr(Folder, ",") - 1), """", "")
    Shell "C:\Windows\explorer.exe /select," & Folder, vbMaximizedFocus
End Sub

---

This part of Main() is easily changed to use what you have for steps 1 and 3. I thought that was fairly easy to understand so I left it for you to add your file attribute parts. FSO can be used directly rather than calling the functions. While you can do it calling functions and I do use similar functions, instantiating the FSO object once is best.

Code:

---

For i = 1 To UBound(y) [
  r.Hyperlinks.Add r, y(i), TextToDisplay:=fso.GetBaseName(y(i))
  Set r = r.Offset(1) 
Next i

---

Since I used the Range Hyperlink method rather than the Hyperlink formula as you did, doing 2 as a new function is even easier. I can show you if needed.

For step 4, that is an FAQ. You have to decide where and how you want to use the stored value. If just needed in ThisWorkbook or ActiveWorkbook, I would use step 1 below. This is very simple. If you need help, post back later.
1. Cell in ThisWorkbook or ActiveWorkbook.
2. Cell in another workbook.
3. Store in registry. See GetSetting().
4. etc.

So, post back for the parts where help is needed. If I get time later and you have not responded, I will work on it a bit.

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

---