VBA question

[rawr19911]

I tried a few times to figure this out but can't figure out how to get Last Saved By name in excel-

.Cells(, 1).Value = fil.Name
.Cells(, 2).Value = fld.Path
.Cells(, 3).Value = Right(fil.Name, Len(fil.Name) - InStrRev(fil.Name, "."))
.Cells(, 4).Value = fil.DateCreated
.Cells(, 5).Value = fil.DateLastAccessed
.Cells(, 6).Value = fil.DateLastModified
.Cells(, 7).Value = fil.LastAuthor (this doesn't work)

here is the full VBA code without the last author / last saved by
Option Explicit
Sub AllFileFolder()
Dim strPath As String
Dim sht As Worksheet
Dim rng As Range
Dim Path As String
Dim fso As Object
Dim fld As Object
Dim fil As Object

strPath = "\\DrivePath"

Set sht = ActiveWorkbook.Worksheets.Add

Set rng = sht.Cells(1, 1)
rng.Resize(, 6).Value = Array("FileName", "FileLocation", "Extension", "CreationDate", "LastAccessDate", "LastModficationDate")

Set fso = CreateObject("Scripting.FileSystemObject")

Set fld = fso.GetFolder(strPath)

getFilesFromFolder fld, rng

MsgBox "Done", vbOKOnly + vbInformation, "Done"
End Sub
Private Sub getFilesFromFolder(fld As Object, rng As Range)
Dim subfld As Object
Dim fil As Object

On Error GoTo ErrHandler

For Each fil In fld.Files

DoEvents

Set rng = rng.Offset(1)

With rng
.Cells(, 1).Value = fil.Name
.Cells(, 2).Value = fld.Path
.Cells(, 3).Value = Right(fil.Name, Len(fil.Name) - InStrRev(fil.Name, "."))
.Cells(, 4).Value = fil.DateCreated
.Cells(, 5).Value = fil.DateLastAccessed
.Cells(, 6).Value = fil.DateLastModified
End With
Next fil


For Each subfld In fld.SubFolders

getFilesFromFolder subfld, rng
Next subfld
ErrHandler:

End Sub

 

[rawr19911]

works perfect thanks!

 

[rawr19911]

Try it as below:

Sub AllFileFolder()
    Dim sPath As String, sht As Worksheet, rng As Range
    Dim fso As Object, fld As Object, fil As Object, subfld As Object
   
    sPath = "\\DrivePath\" ' needs to end with a \
   
    Set sht = ActiveWorkbook.Worksheets.Add
    Set rng = sht.Cells(1, 1)
    rng.Resize(, 7) = Array("FileName", "FileLocation", "Extension", "CreationDate", "LastAccessDate", "LastModficationDate", "LastSavedBy")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fld = fso.GetFolder(sPath)
   
NextSFold:
    For Each fil In fld.Files
        Set rng = rng.Offset(1)
        With rng
            .Resize(, 7) = GetAuthorFromShell(fld & "\", fil.Name)
        End With
    Next fil
   
    For Each subfld In fld.SubFolders
        Set fld = fso.GetFolder(subfld.Path)
        GoTo NextSFold
    Next subfld
End Sub

Function GetAuthorFromShell(strPath As String, strFileName As String) As Variant
    Dim nm As String, pth As String, typ As String, dcr As Date, dac As Date, dmod As Date, lsby As String
    Dim varPath As Variant, varFileName As Variant
    Dim objShell As Object, objFolder As Object
   
    varPath = strPath
    varFileName = strFileName

    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(varPath)

    With objFolder
        On Error Resume Next
            nm = .getdetailsof(.Items.Item(varFileName), 0)
            pth = varPath & varFileName
            typ = .getdetailsof(.Items.Item(varFileName), 2)
            dcr = CDate(.getdetailsof(.Items.Item(varFileName), 4))
            dac = CDate(.getdetailsof(.Items.Item(varFileName), 5))
            dmod = CDate(.getdetailsof(.Items.Item(varFileName), 3))
            lsby = .getdetailsof(.Items.Item(varFileName), 10)
        On Error GoTo 0
    End With
   
    GetAuthorFromShell = Array(nm, pth, typ, dcr, dac, dmod, lsby)
End Function

it works perfect- it doesn't do the subfolders which thats okay- i can pull everything out of the subfolders and put in one location

 

[Georgiboy]

You are welcome, it works for subfolders for me, but maybe not subfolders of subfolders if that makes sense.

 

[rawr19911]

You are welcome, it works for subfolders for me, but maybe not subfolders of subfolders if that makes sense.

it does make sense it does what i need-