Note: This has been posted on another forum - no response yet.
I am using the following code, developed by other/s and modified to suit my needs, to list all the files in a selected folder and its sub-folders.
It also lists the attribute "Title" by using "objFolder.GetDetailsOf(objFolderItem, 21)".
The code works fine listing the "Title" attribute for PDF and JPEG files but gives a blank for Excel and Word documents.
When I check in Windows Explorer attributes such as "Title", "Subject" and "Comments" do show up. But when I go to the same directory using an alternative file browser, in this case Q-Dir, the attributes do not show up (they do show up for PDF and JPEG files though).
I am using Windows 7, Excel 2007 and Word 2007.
"objFolder.GetDetailsOf(objFolderItem, 21)" gives the "Title" attribute in Windows 7 apparently but it differs for Windows xp (10 instead of 21).
I am using the following code, developed by other/s and modified to suit my needs, to list all the files in a selected folder and its sub-folders.
It also lists the attribute "Title" by using "objFolder.GetDetailsOf(objFolderItem, 21)".
The code works fine listing the "Title" attribute for PDF and JPEG files but gives a blank for Excel and Word documents.
When I check in Windows Explorer attributes such as "Title", "Subject" and "Comments" do show up. But when I go to the same directory using an alternative file browser, in this case Q-Dir, the attributes do not show up (they do show up for PDF and JPEG files though).
I am using Windows 7, Excel 2007 and Word 2007.
"objFolder.GetDetailsOf(objFolderItem, 21)" gives the "Title" attribute in Windows 7 apparently but it differs for Windows xp (10 instead of 21).
Code:
Sub TestListFilesInFolder()
Dim sFolder As FileDialog
Set sFolder = Application.FileDialog(msoFileDialogFolderPicker)
If sFolder.Show = -1 Then
ListFilesInFolder sFolder.SelectedItems(1), True
End If
End Sub
Sub ListFilesInFolder(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
Cells(r, 12).Formula = Chr(61) & "HYPERLINK(" & Chr(34) & FileItem.Path & Chr(34) & "," & Chr(34) & FileItem.Name & Chr(34) & ")"
Cells(r, 20).Formula = GetFileOwner(SourceFolder.Path, FileItem.Name)
Cells(r, 44).Formula = FileItem.Path
r = r + 1
X = SourceFolder.Path
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
ActiveWorkbook.Saved = True
End Sub
Function GetFileOwner(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
GetFileOwner = objFolder.GetDetailsOf(objFolderItem, 21)
Else
GetFileOwner = ""
End If
Set objShell = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
End Function