VBA List Files in Folder with Author & Last Saved by Properties

[MrzSanchez]

Help Pretty please. My brain hurts and I still can't get the right code. I need VBA to return file author and last saved by. Here is the current code:


Option Explicit
'the first row with data
Const ROW_FIRST As Integer = 2, TFNameCol As Integer = 9, TFCountCol As Integer = 10, intTimeColumn As Integer = 11
Public TabName As String, RawTabName As String
Private Declare Function GetTickCount Lib "kernel32" () As Long
Sub btnGetFiles_Click()
Dim intResult As Double 'the current number of rows
Dim strPath As String, UNCPath As String, objFSO As Object, intTabCounter As Integer, intTabCountRow As Integer
Dim intCountRows As Double
Application.StatusBar = "FileLister Utility - Author: Author Name"
Dim StartTime As Double
Dim MinutesElapsed As String
StartTime = Timer 'Remember time when macro starts
Application.FileDialog(msoFileDialogFolderPicker).Title = "Select a Path"
intResult = Application.FileDialog(msoFileDialogFolderPicker).Show 'the dialog is displayed to the user
If intResult <> 0 Then 'checks if user has cancled the dialog

Application.ScreenUpdating = False
strPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
If Left(strPath, 5) = "http:" Then
strPath = Mid(strPath, 6)
strPath = Replace(strPath, "/", "")
End If
UNCPath = strPath
If InStr(strPath, ":") Then
UNCPath = Path2UNC(strPath)
End If
Set objFSO = CreateObject("Scripting.FileSystemObject") 'Create an instance of the FileSystemObject
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
RawTabName = Right(UNCPath, Len(UNCPath) - InStrRev(UNCPath, "")) ' Grabbing the selected Folder Name to name worksheet tab
TabName = Replace(RawTabName, " ", "")
TabName = Replace(TabName, "-", "")
Sheets(Worksheets.Count).Name = Right(TabName, 30)
TabName = Sheets(Worksheets.Count).Name
Application.ScreenUpdating = True
Application.StatusBar = "Retreving file names for path: " & UNCPath
Application.ScreenUpdating = False
Sheets(TabName).Select
intTabCounter = Worksheets.Count
intTabCountRow = intTabCounter + 11
ActiveWorkbook.Sheets("Start Here").Cells(intTabCountRow, TFNameCol) = "'" & TabName
'Debug.Print "Creating " & Right(TabName, 30)
ActiveWorkbook.Sheets(TabName).Range("A1") = "Full File Path and name"
ActiveWorkbook.Sheets(TabName).Range("B1") = "Date Created"
ActiveWorkbook.Sheets(TabName).Range("C1") = "Date Last Modified"
ActiveWorkbook.Sheets(TabName).Range("D1") = "Date Last Accessed"
ActiveWorkbook.Sheets(TabName).Range("E1") = "Root Folder/Share Name"
ActiveWorkbook.Sheets(TabName).Range("F1") = "File Name"
intCountRows = GetAllFiles(UNCPath, ROW_FIRST, objFSO) 'loop through each file in the directory and prints the path
Call GetAllFolders(UNCPath, objFSO, intCountRows) 'loop through all the files and folder in the input path
Sheets("Start Here").Activate
Beep
'Determine how many seconds code took to run
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
'Notify user in seconds
' MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation
ActiveWorkbook.Sheets("Start Here").Cells(intTabCountRow, TFCountCol) = intCountRows - 2
ActiveWorkbook.Sheets("Start Here").Cells(intTabCountRow, intTimeColumn) = MinutesElapsed
ActiveWorkbook.Sheets(TabName).Columns.AutoFit
Application.ScreenUpdating = True
' MsgBox "File listing for " & intCountRows - 1 & " files, in Path: " & strPath & " Completed. Time Elapsed: " & MinutesElapsed & ". See results on Tab, named : " & Right(TabName, 30)
Application.StatusBar = "File listing for " & intCountRows - 1 & " files, in Path: " & strPath & " Completed. Time Elapsed: " & MinutesElapsed & ". See results on Tab, named : " & Right(TabName, 30)
End If
Application.ScreenUpdating = True
End Sub
'print the path of all the files in the directory strPath
Private Function GetAllFiles(ByVal UNCPath As String, ByVal intRow As Double, ByRef objFSO As Object) As Double
Dim objFolder As Object, objFile As Object, i As Double, strFileNameNoExt As String, strFileName As String
i = intRow - ROW_FIRST + 1
Set objFolder = objFSO.GetFolder(UNCPath)
Application.ScreenUpdating = True
Beep
Application.StatusBar = "Retreiving file names for path: " & UNCPath
Application.ScreenUpdating = False
On Error Resume Next
For Each objFile In objFolder.Files
Application.StatusBar = "Retreiving file names for path: " & UNCPath
Application.ScreenUpdating = False
ActiveWorkbook.Sheets(TabName).Cells(i + ROW_FIRST - 1, 1) = objFile.Path 'print file path
ActiveWorkbook.Sheets(TabName).Cells(i + ROW_FIRST - 1, 2) = objFile.DateCreated
ActiveWorkbook.Sheets(TabName).Cells(i + ROW_FIRST - 1, 3) = objFile.DateLastModified
ActiveWorkbook.Sheets(TabName).Cells(i + ROW_FIRST - 1, 4) = objFile.DateLastAccessed
If Right(objFile.Path, 3) = "zip" Then
ActiveWorkbook.Sheets(TabName).Cells(i + ROW_FIRST - 1, 1).Font.Color = vbRed
ActiveWorkbook.Sheets(TabName).Cells(i + ROW_FIRST - 1, 1).Font.Bold = True
End If
If Right(objFile.Path, 9) = "Thumbs.db" Then
ActiveWorkbook.Sheets(TabName).Cells(i + ROW_FIRST - 1, 1).Font.Color = vbRed
ActiveWorkbook.Sheets(TabName).Cells(i + ROW_FIRST - 1, 1).Font.Bold = True
End If
strFileName = objFSO.GetFileName(objFile.Path)
strFileNameNoExt = JustStem(objFile.Path)
GrabShareNameAndFileNAme (objFile.Path)
' JustFSRoot (objFile.Path)
ActiveWorkbook.Sheets(TabName).Cells(i + ROW_FIRST - 1, 5) = JustFSRoot(objFile.Path)
ActiveWorkbook.Sheets(TabName).Cells(i + ROW_FIRST - 1, 6) = strFileName

i = i + 1
Next objFile
On Error GoTo 0
GetAllFiles = i + ROW_FIRST - 1
End Function
'loop through all the folders in the input path. It makes a call to the GetAllFiles function.
Private Sub GetAllFolders(ByVal strFolder As String, ByRef objFSO As Object, ByRef intRow As Double)
Dim objFolder As Object, objSubFolder As Object
Set objFolder = objFSO.GetFolder(strFolder) 'Get the folder object
On Error Resume Next
For Each objSubFolder In objFolder.SubFolders 'loops through each file in the directory and prints the path
Application.ScreenUpdating = True
' Beep
Application.StatusBar = "Retreiving file names for path: " & objSubFolder.Path
Application.ScreenUpdating = False
intRow = GetAllFiles(objSubFolder.Path, intRow, objFSO)
Call GetAllFolders(objSubFolder.Path, objFSO, intRow) 'recursive call to to itsself
GiveRoutineA_Break
Next objSubFolder
On Error GoTo 0
End Sub

Function Path2UNC(strFullPathName As String) As String
' Converts the mapped drive path in strFullPathName to a UNC path if one exists. If not, returns original string
Dim sDrive As String, i As Long
Application.Volatile
sDrive = UCase(Left(strFullPathName, 2))
With CreateObject("WScript.Network").EnumNetworkDrives
For i = 0 To .Count - 1 Step 2
If .Item(i) = sDrive Then
Path2UNC = .Item(i + 1) & Mid(strFullPathName, 3)
Exit For
End If
Next
End With
If Path2UNC = "" Then Path2UNC = strFullPathName
End Function

Function GrabShareNameAndFileNAme(strPath)
Dim sFileName, sExtension, sShareName
'sFileName = Split(strPath, "")(UBound(Split(strPath, "")))
sExtension = Split(sFileName, ".")(LBound(Split(sFileName, ".")))
sShareName = Split(strPath, "")(LBound(Split(strPath, "")))
End Function
Function JustPath(cFullName)
Dim nPoz As Integer
'The JustPath function returns the path name from a full file name. It handles both UNC and regular full file names:
If Left(cFullName, 2) = "" Then
nPoz = InStrRev(Right(cFullName, (Len(cFullName) - 2)), "")
If nPoz <> 0 Then
JustPath = Left(cFullName, nPoz + 2)
Else
JustPath = cFullName
End If
Else
JustPath = Left(cFullName, InStrRev(cFullName, ""))
End If

End Function
Function JustServer(cFullName)
Dim nPoz As Integer
If Left(cFullName, 2) = "" Then
nPoz = InStr(3, cFullName, "")
If nPoz > 0 Then
JustServer = Left(cFullName, nPoz - 1)
Else
JustServer = cFullName
End If
Else
JustServer = ""
End If
End Function
Function JustFSRoot(cFullName)
Dim cPth, cDrv, cSrv
cPth = JustPath(cFullName)
cDrv = JustDrive(cPth)
cSrv = JustServer(cPth)
If cDrv = "" And cSrv = "" Then
JustFSRoot = ""
Else
If cDrv <> "" Then
JustFSRoot = cDrv
Else
Dim nPoz As Integer
If cSrv <> cPth Then
nPoz = InStr(Len(cSrv) + 2, cPth, "")
If nPoz = 0 Then

JustFSRoot = cPth
Else
JustFSRoot = Left(cPth, nPoz - 1)
End If
Else
JustFSRoot = ""
End If
End If
End If
End Function

Function JustDrive(cFullName)
If Mid(cFullName, 2, 1) = ":" Then
JustDrive = Left(cFullName, 2)
Else
JustDrive = ""
End If
End Function
Function JustFName(cFullName)
Dim nPoz As Integer
nPoz = Len(JustPath(cFullName))
JustFName = Right(cFullName, Len(cFullName) - nPoz)
End Function
Function JustStem(cFullName)
JustStem = JustFName(cFullName)
If InStrRev(cFullName, ".") <> 0 Then
JustStem = Left(cFullName, _
InStrRev(cFullName, ".") - 1)
Else
JustStem = Trim(cFullName)
End If
End Function

Sub GiveRoutineA_Break()
Dim StartTick As Long
Dim CurrTick As Long
Dim EndTick As Long
On Error GoTo ErrHandler
Application.EnableCancelKey = xlErrorHandler
StartTick = GetTickCount
EndTick = GetTickCount + (1 * 1000)
Do
CurrTick = GetTickCount
DoEvents
Loop Until CurrTick >= EndTick
Exit Sub
ErrHandler:
' Break Key Pressed
EndTick = 0
End Sub

 

[Logit]

This will provide: Computer Name - Open Time - Close Time - Open WB Name - Close WB Name

All of this code goes in the ThisWorkbook module to catch the opening and closing of the workbook.
Now if you can get some code to return the AUTHOR, you've got it going on !

You need to have a hidden sheet named "Audit" for the logging entries by the macro.

Option Explicit


Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" ( _
    ByVal lpBuffer As String, _
    nSize As Long) As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" ( _
    ByVal lpBuffer As String, _
    nSize As Long) As Long


Private pAuditSheet As Worksheet
Private Const USERNAME_COL = 1
Private Const COMPUTERNAME_COL = 2
Private Const OPEN_TIME_COL = 3
Private Const CLOSE_TIME_COL = 4
Private Const OPEN_WB_NAME_COL = 5
Private Const CLOSE_WB_NAME_COL = 6
Private Const KEEP_ONLY_LAST_N_ENTRIES = 10


Private Sub Workbook_Open()
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Workbook_Open
    ' Runs when the workbook is opened.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim WS As Worksheet
    Dim RowNum As Long
    Dim N As Long
    Dim S As String
    
    Application.ScreenUpdating = False
    On Error Resume Next
    Err.Clear
    Set WS = Me.Worksheets("Audit")
    If Err.Number = 9 Then
        Set WS = Me.Worksheets.Add(before:=1)
        WS.Name = "Audit"
    End If
    On Error GoTo 0
    With WS
        If .Cells(1, USERNAME_COL).Value = vbNullString Then
            .Cells(1, USERNAME_COL).Value = "User Name"
            .Cells(1, COMPUTERNAME_COL).Value = "Computer Name"
            .Cells(1, OPEN_TIME_COL).Value = "Open Time"
            .Cells(1, CLOSE_TIME_COL).Value = "Close Time"
            .Cells(1, OPEN_WB_NAME_COL).Value = "Open WB Name"
            .Cells(1, CLOSE_WB_NAME_COL).Value = "Close WB Name"
        End If
        .Visible = xlSheetVeryHidden
        RowNum = .Cells(.Rows.Count, USERNAME_COL).End(xlUp)(2, 1).Row
        N = 255
        S = String(N, vbNullChar)
        N = GetUserName(S, N)
        .Cells(RowNum, USERNAME_COL).Value = TrimToNull(S)
        N = 255
        S = String(N, vbNullChar)
        N = GetComputerName(S, N)
        .Cells(RowNum, COMPUTERNAME_COL).Value = TrimToNull(S)
        .Cells(RowNum, OPEN_TIME_COL).Value = Now
        ' Leave Close Time empty. It will be filled on close.
        .Cells(RowNum, CLOSE_TIME_COL).Value = vbNullString
        .Cells(RowNum, OPEN_WB_NAME_COL).Value = ThisWorkbook.FullName
        ' Leave Close Name empty. It will be filled on close.
        .Cells(RowNum, CLOSE_WB_NAME_COL).Value = vbNullString
        .UsedRange.Columns.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub




Private Sub Workbook_BeforeClose(Cancel As Boolean)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Workbook_BeforeClose
' Runs when the workbook is closed.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim WS As Worksheet
    Dim RowNum As Long
    Dim EndRow As Long
    Dim LastDel As Long
    Dim FirstDel As Long
    
    Application.ScreenUpdating = False
    Set WS = Worksheets("Audit")
    With WS
        RowNum = .Cells(.Rows.Count, CLOSE_TIME_COL).End(xlUp).Row + 1
        .Cells(RowNum, CLOSE_TIME_COL).Value = Now
        .Cells(RowNum, CLOSE_WB_NAME_COL).Value = ThisWorkbook.FullName
        .UsedRange.Columns.AutoFit
        If KEEP_ONLY_LAST_N_ENTRIES > 0 Then
            EndRow = .Cells(.Rows.Count, USERNAME_COL).End(xlUp).Row
            If EndRow > 2 Then
                FirstDel = 2
                LastDel = EndRow - KEEP_ONLY_LAST_N_ENTRIES
                If LastDel > 2 Then
                    .Cells(FirstDel, "A").Resize(LastDel - 1, 1).Select
                End If
            End If
        End If
    End With
    
    Application.ScreenUpdating = True
End Sub




Private Function TrimToNull(S As String) As String
'''''''''''''''''''''''''''''''''''''''''''''''''''
' TrimToNull
' Returns the portion of string S that is to the
' left of the vbNullChar, Chr(0).
'''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim N As Long
    N = InStr(1, S, vbNullChar)
    If N = 0 Then
        TrimToNull = S
    Else
        TrimToNull = Left(S, N - 1)
    End If
End Function
''''''''''''''''''''''''''''''''''''''''''
' END CODE
''''''''''''''''''''''''''''''''''''''''''