Need help adding author to indexing file

Eat Well

New Member
Joined
Jul 2, 2014
Messages
22
Hi everyone,

First off thank you for taking the time to view my post, it means a lot. Also sorry for coming in right away with what may be a basic question but I know very little about code and was looking for some help. I'm trying to get a document together that will spit out an index of all the files in a folder/subfolder with various attributes like title name/ hyperlink to the file/ type/ etc. I was able to attain most of the code from a website run by a Mr. Vishwa which I'll link below for sources. I have not been able to figure out how to add a function that will create a column/pull data for the author of the files I am indexing. Could anyone please help?

Code:
Public fPath As String
Public IsSubFolder As Boolean
Public iRow As Long
Public FSO As Scripting.FileSystemObject
Public SourceFolder As Scripting.folder, SubFolder As Scripting.folder
Public FileItem As Scripting.File
Public IsFileTypeExists As Boolean






Public Sub ListFilesInFolder(SourceFolder As Scripting.folder, IncludeSubfolders As Boolean)
    
    
    On Error Resume Next
    For Each FileItem In SourceFolder.Files
        
        
' display file properties
        Cells(iRow, 2).Formula = iRow - 13
        Cells(iRow, 3).Formula = FileItem.Name
        Cells(iRow, 4).Formula = FileItem.Path
        Cells(iRow, 5).Formula = Int(FileItem.Size / 1024)
        Cells(iRow, 6).Formula = FileItem.Type
        Cells(iRow, 7).Formula = FileItem.DateLastModified
        Cells(iRow, 8).Select
        Selection.Hyperlinks.Add Anchor:=Selection, Address:= _
        FileItem.Path, TextToDisplay:="Click Here to Open"
        
'Cells(iRow, 8).Formula = "=HYPERLINK(""" & FileItem.Path & """,""" & "Click Here to Open" & """)"
        
        iRow = iRow + 1 ' next row number
        Next FileItem
        
        If IncludeSubfolders Then
            For Each SubFolder In SourceFolder.SubFolders
                ListFilesInFolder SubFolder, True
                Next SubFolder
            End If
            
            Set FileItem = Nothing
            Set SourceFolder = Nothing
            Set FSO = Nothing
            
            
            
        End Sub
        
        
        
        
        Public Sub ListFilesInFolderXtn(SourceFolder As Scripting.folder, IncludeSubfolders As Boolean)
            
            
            On Error Resume Next
            Dim FileArray As Variant
            
            FileArray = Get_File_Type_Array
            
            For Each FileItem In SourceFolder.Files
                
                Call ReturnFileType(FileItem.Type, FileArray)
                
                If IsFileTypeExists = True Then
                    
                    Cells(iRow, 2).Formula = iRow - 13
                    Cells(iRow, 3).Formula = FileItem.Name
                    Cells(iRow, 4).Formula = FileItem.Path
                    Cells(iRow, 5).Formula = Int(FileItem.Size / 1024)
                    Cells(iRow, 6).Formula = FileItem.Type
                    Cells(iRow, 7).Formula = FileItem.DateLastModified
                    
                    Cells(iRow, 8).Select
                    Selection.Hyperlinks.Add Anchor:=Selection, Address:= _
                    FileItem.Path, TextToDisplay:="Click Here to Open"
                    
                
'Cells(iRow, 8).Formula = "=HYPERLINK(""" & FileItem.Path & """,""" & "Click Here to Open" & """)"
                    
                    iRow = iRow + 1 ' next row number
                    
                End If
                Next FileItem
                
                If IncludeSubfolders Then
                    For Each SubFolder In SourceFolder.SubFolders
                        ListFilesInFolderXtn SubFolder, True
                        Next SubFolder
                    End If
                    
                    Set FileItem = Nothing
                    Set SourceFolder = Nothing
                    Set FSO = Nothing
                    
                    
                    
                End Sub
                
                
                
                Sub ResultSorting(xlSortOrder As String, sKey1 As String, sKey2 As String, sKey3 As String)
                    Range("C13").Select
                    Range(Selection, Selection.End(xlDown)).Select
                    Range(Selection, Selection.End(xlToRight)).Select
                    
                    Selection.Sort Key1:=Range(sKey1), Order1:=xlSortOrder, Key2:=Range(sKey2 _
                    ), Order2:=xlAscending, Key3:=Range(sKey3), Order3:=xlSortOrder, Header _
                    :=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom _
                    , DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
                    xlSortNormal
                    
                    Range("B14").Select
                End Sub
                
                
                Sub ClearResult()
                    If Range("B14") <> "" Then
                        
                        Range("B14").Select
                        Range(Selection, Selection.End(xlDown)).Select
                        Range(Selection, Selection.End(xlToRight)).Select
                        Range(Selection.Address).ClearContents
                    End If
                End Sub
                
                
                Public Function Get_File_Type_Array() As Variant
                    
                    Dim i, j, TotalSelected As Integer
                    Dim arrList() As String
                    TotalSelected = 0
                    For i = 0 To Sheet1.ListBoxFileTypes.ListCount - 1
                        If Sheet1.ListBoxFileTypes.Selected(i) = True Then
                            TotalSelected = TotalSelected + 1
                        End If
                    Next
                    
                    ReDim arrList(0 To TotalSelected - 1) As String
                    j = 0
                    i = 0
                    For i = 0 To Sheet1.ListBoxFileTypes.ListCount - 1
                        
                        If Sheet1.ListBoxFileTypes.Selected(i) = True Then
                            arrList(j) = Left(Sheet1.ListBoxFileTypes.List(i), InStr(1, Sheet1.ListBoxFileTypes.List(i), "(") - 1)
                            j = j + 1
                        End If
                        
                    Next
                    
                    Get_File_Type_Array = arrList
                    
                End Function
                
                
                Public Function ReturnFileType(fileType As String, FileArray As Variant) As Boolean
                    
                    Dim i As Integer
                    
                    IsFileTypeExists = False
                    
                    For i = 1 To UBound(FileArray) + 1
                        
                        If FileArray(i - 1) = fileType Then
                            
                            IsFileTypeExists = True
                            Exit For
                            
                        Else
                            IsFileTypeExists = False
                        End If
                        
                    Next
                    
                End Function
                
                
                
                Sub textfile(iSeperator As String)
                    
                    Dim iRow, iCol
                    Dim iLine, f
                    
                    
                    
                    
                    ThisWorkbook.Activate
                    Range("B13").Select
                    TotalRowNumber = Range(Selection, Selection.End(xlDown)).Count - 12
                    
                    If iSeperator <> "vbTab" Then
                        
                        Open ThisWorkbook.Path & "\File1.txt" For Output As #1
                        Print #1, ""
                        Close #1
                        
                        Open ThisWorkbook.Path & "\File1.txt" For Append As #1
                        For iRow = 13 To TotalRowNumber
                            
                            iLine = ""
                            
                            For iCol = 2 To 7
                                
                                iLine = iLine & iSeperator & Cells(iRow, iCol).Value
                            Next
                            Print #1, iLine
                        Next
                        Close #1
                        
                        
                    Else
                        
                        Open ThisWorkbook.Path & "\File1.txt" For Output As #1
                        Print #1, ""
                        Close #1
                        
                        Open ThisWorkbook.Path & "\File1.txt" For Append As #1
                        For iRow = 13 To TotalRowNumber
                            
                            iLine = ""
                            
                            For iCol = 2 To 7
                                
                                iLine = iLine & vbTab & Cells(iRow, iCol).Value
                            Next
                            Print #1, iLine
                        Next
                        Close #1
                        
                    End If
                    
                    
                    
                    f = Shell("C:\WINDOWS\notepad.exe " & ThisWorkbook.Path & "\File1.txt", vbMaximizedFocus)
                    
'MsgBox "Your File is saved" & ThisWorkbook.Path & "\File1.txt"
                    
                End Sub
                
                
                
                
                
                Sub Export_to_excel()
                    On Error GoTo err
                    
                    
                    
                    Dim xlApp As New Excel.Application
                    Dim xlWB As New Workbook
                    
                    Set xlWB = xlApp.Workbooks.Add
'xlWB.Add
                    xlApp.Visible = False
                    
                    
                    ThisWorkbook.Activate
                    Range("B13").Select
                    Range(Selection, Selection.End(xlDown)).Select
                    Range(Selection, Selection.End(xlToRight)).Select
                    
                    Selection.Copy
                    
                    xlApp.Visible = True
                    xlWB.Activate
                    xlWB.Sheets("Sheet1").Select
                    xlWB.Sheets("Sheet1").Range("B2").PasteSpecial Paste:=xlPasteValues
                    xlWB.Sheets("Sheet1").Cells.Select
                    xlWB.Sheets("Sheet1").Cells.EntireColumn.AutoFit
                    xlWB.Sheets("Sheet1").Range("B2").Select
                    Exit Sub
err:
                    MsgBox ("Error Occured while exporting. Try again")
                    
                End Sub

Here's the website: Learn Excel Macro How to get list of All files in a Folder and Sub-folders

Once again, I'm just trying to figure out how to get a column that lists the author of the document. Thank you in advance for any/all input.
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
So through some research of my own I edited the code to show the author of the workbook. But it's the author of the index file, so they're all the same. I'm trying to find the author of the file I am referring to in the index. Here's my new code


Code:
' display file properties
        Cells(iRow, 2).Formula = iRow - 13
        Cells(iRow, 3).Formula = FileItem.Name
        Cells(iRow, 4).Formula = FileItem.Path
        Cells(iRow, 5).Formula = Int(FileItem.Size / 1024)
        Cells(iRow, 6).Formula = FileItem.Type
        Cells(iRow, 7).Formula = FileItem.DateLastModified
        Cells(iRow, 8).Select
        Selection.Hyperlinks.Add Anchor:=Selection, Address:= _
        FileItem.Path, TextToDisplay:="Click Here to Open"
        Cells(iRow, 9).Formula = ThisWorkbook.BuiltinDocumentProperties("author").Value
 
Upvote 0

Forum statistics

Threads
1,213,489
Messages
6,113,947
Members
448,534
Latest member
benefuexx

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top