PDA

View Full Version : Selective listing of files in a folder



Indigenous
05-11-2016, 03:47 AM
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]



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

SamT
05-11-2016, 06:23 AM
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

Set SourceFolder = FSO.GetFolder(SourceFolderName) add

Dim AllFiles(1 to SourceFolder.Count)
For i = 1 to SourceFolder.Count
AllFiles(i) = SourceFolder.Items(i)
Nextthen sort the array allFiles.

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

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.

Indigenous
05-12-2016, 03:47 AM
I get an error message: "Compile error: Constant expression required".
.Count is highlighted in the line: "Dim AllFiles(1 To SourceFolder.Count)".

SamT
05-12-2016, 05:37 AM
Sorry, all my reference files on the broken computer.

Not to worry, somebody else will be along shortly.

Kenneth Hobs
05-12-2016, 11:39 AM
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.

Indigenous
06-07-2016, 05:07 AM
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>

Kenneth Hobs
06-07-2016, 05:35 AM
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.

snb
06-07-2016, 06:56 AM
to retrieve the last version of file 'example.xlsx' in directory 'G:\OF'


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

Indigenous
06-08-2016, 04:39 AM
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.

Paul_Hossler
06-08-2016, 05:50 AM
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]???

Indigenous
06-09-2016, 02:03 AM
1. Prefer folder tree. Single folder acceptable.
2. Cannot understand ... assuming searching one folder only. In Folder 1, return Filename[2].
3. Yes.

Kenneth Hobs
06-09-2016, 08:41 AM
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.

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

Paul_Hossler
06-09-2016, 03:28 PM
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

SamT
06-09-2016, 04:12 PM
@ 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.

Indigenous
06-11-2016, 01:43 AM
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].

Indigenous
06-11-2016, 01:53 AM
Kenneth, I get an error message when I run the code.
Compile error: User-defined type not defined.
Highlights "Dim FSO As FileSystemObject"

Kenneth Hobs
06-11-2016, 09:59 AM
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.

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

Indigenous
06-11-2016, 10:37 PM
Kenneth, this works!
Thx for the effort.

Indigenous
06-18-2016, 01:01 AM
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

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)

Option Explicit

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


*** Code 2b

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

Kenneth Hobs
06-18-2016, 06:50 AM
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.

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.

Kenneth Hobs
06-18-2016, 08:40 AM
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.

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:

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

Indigenous
06-18-2016, 07:39 PM
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.

Kenneth Hobs
06-18-2016, 07:54 PM
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.

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

Indigenous
06-18-2016, 08:19 PM
Thx.
All the best.

Indigenous
06-22-2016, 01:48 AM
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.

snb
06-22-2016, 02:20 AM
@KH



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

Kenneth Hobs
06-22-2016, 06:45 AM
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

Indigenous
06-23-2016, 01:33 AM
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.

snb
06-23-2016, 02:13 AM
@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.

SamT
06-23-2016, 07:28 AM
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.

Indigenous
09-19-2016, 09:44 PM
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?

Kenneth Hobs
09-20-2016, 05:11 AM
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

Indigenous
09-21-2016, 12:16 AM
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:


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:


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