VBA Get File Attributes !!!!

[QuintonMcCloud]

Hi

I am using the following formula to try and get file attributes on a shared drive. I am currently running into a few issues that I am wondering if I can get some guidance and or assistance in. The issues with the formula at the moment are:

1. The formula is looping for a long time and is causing excel to crash in particular if it is reading more files (not more than 65000 as stipulated in the formula)
2. At the moment the formula works fine if I am manually directing it to subfolders etc but if I point it towards a primary folder it crashes or takes a long time to return results. Is there a way I can perhaps try and speed up this process?

The objective is to use this for Document Control purposes. I want to be able to run the code and be able to extract data in relation to the path, file name, format, last accessed and so forth. The results have to be returned in excel where I have a database that I am collating all of the information together.

PS: THE BUTTON TO RUN THE CODE IS ON THE INTRO WORKSHEET TAB

Code:

Public X()
Public i As Long
Public objShell, objFolder, objFolderItem
Public FSO, oFolder, Fil

Sub MainExtractData()

    Dim NewSht As Worksheet
    Dim MainFolderName As String
    Dim TimeLimit As Long, StartTime As Double

    ReDim X(1 To 500000, 1 To 11)

    Set objShell = CreateObject("Shell.Application")
    TimeLimit = Application.InputBox("Please enter the maximum time that you wish this code to run for in minutes" & vbNewLine & vbNewLine & _
                                     "Leave this at zero for unlimited runtime", "Time Check box", 0)
    StartTime = Timer

    Application.ScreenUpdating = False
    MainFolderName = BrowseForFolder()
    Set NewSht = ThisWorkbook.Sheets.Add

    X(1, 1) = "Path"
    X(1, 2) = "File Name"
    X(1, 3) = "Last Accessed"
    X(1, 4) = "Last Modified"
    X(1, 5) = "Created"
    X(1, 6) = "Type"
    X(1, 7) = "Size"
    X(1, 8) = "Owner"
    X(1, 9) = "Author"
    X(1, 10) = "Title"
    X(1, 11) = "Comments"

    i = 1

    Set FSO = CreateObject("scripting.FileSystemObject")
    Set oFolder = FSO.GetFolder(MainFolderName)
    'error handling to stop the obscure error that occurs at time when retrieving DateLastAccessed
    On Error Resume Next
    For Each Fil In oFolder.Files
        Set objFolder = objShell.Namespace(oFolder.path)
        Set objFolderItem = objFolder.ParseName(Fil.Name)
        i = i + 1
        If i Mod 20 = 0 And TimeLimit <> 0 And Timer > (TimeLimit * 60 + StartTime) Then
            GoTo FastExit
        End If
        If i Mod 50 = 0 Then
            Application.StatusBar = "Processing File " & i
            DoEvents
        End If
        X(i, 1) = oFolder.path
        X(i, 2) = Fil.Name
        X(i, 3) = Fil.DateLastAccessed
        X(i, 4) = Fil.DateLastModified
        X(i, 5) = Fil.DateCreated
        X(i, 6) = Fil.Type
        X(i, 7) = Fil.Size
        X(i, 8) = objFolder.GetDetailsOf(objFolderItem, 8)
        X(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
        X(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
        X(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
    Next

    'Get subdirectories
    If TimeLimit = 0 Then
        Call RecursiveFolder(oFolder, 0)
    Else
        If Timer < (TimeLimit * 60 + StartTime) Then Call RecursiveFolder(oFolder, TimeLimit * 60 + StartTime)
    End If

FastExit:
    Range("A:K") = X
    If i < 65535 Then Range(Cells(i + 1, "A"), Cells(65536, "A")).EntireRow.Delete
    Range("A:K").WrapText = False
    Range("A:K").EntireColumn.AutoFit
    Range("1:1").Font.Bold = True
    Rows("2:2").Select
    ActiveWindow.FreezePanes = True
    Range("a1").Activate

    Set FSO = Nothing
    Set objShell = Nothing
    Set oFolder = Nothing
    Set objFolder = Nothing
    Set objFolderItem = Nothing
    Set Fil = Nothing
    Application.StatusBar = ""
    Application.ScreenUpdating = True
End Sub

Sub RecursiveFolder(xFolder, TimeTest As Long)
    Dim SubFld
    For Each SubFld In xFolder.SubFolders
        Set oFolder = FSO.GetFolder(SubFld)
        Set objFolder = objShell.Namespace(SubFld.path)
        For Each Fil In SubFld.Files
            Set objFolder = objShell.Namespace(oFolder.path)
            'Problem with objFolder at times
            If Not objFolder Is Nothing Then
                Set objFolderItem = objFolder.ParseName(Fil.Name)
                i = i + 1
                If i Mod 20 = 0 And TimeTest <> 0 And Timer > TimeTest Then
                    Exit Sub
                End If
                If i Mod 50 = 0 Then
                    Application.StatusBar = "Processing File " & i
                    DoEvents
                End If
                X(i, 1) = SubFld.path
                X(i, 2) = Fil.Name
                X(i, 3) = Fil.DateLastAccessed
                X(i, 4) = Fil.DateLastModified
                X(i, 5) = Fil.DateCreated
                X(i, 6) = Fil.Type
                X(i, 7) = Fil.Size
                X(i, 8) = objFolder.GetDetailsOf(objFolderItem, 8)
                X(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
                X(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
                X(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
            Else
                Debug.Print Fil.path & " " & Fil.Name
            End If
        Next
        Call RecursiveFolder(SubFld, TimeTest)
    Next
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose:  To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE:  If invalid, it will open at the Desktop level

    Dim ShellApp As Object

    'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
                   BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

    'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.path
    On Error GoTo 0

    'Destroy the Shell Application
    Set ShellApp = Nothing

    'Check for invalid or non-entries and send to the Invalid error
    'handler if found
    'Valid selections can begin L: (where L is a letter) or
    '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select

    Exit Function

Invalid:
    'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False

End Function

[/QUOTE]