• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

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

M

MrzSanchez

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


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: Mr Boss, COO"
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
 
Last edited by a moderator:
Thanks Monty! this is very similar to my code. Unfortunately it doesn't list the document author either though. = (
 
Monty this is awesome and will be very useful to me so thanks for posting. Is there any way to add the "Authors" or "last saved by"?
 
Last edited by a moderator:
You must log in or register to reply here.
Back
Top