Utiliser fichier fermé pour récupérer nbr code lines

Private Sub TypeFich_Change()
Fil = Dir(Me.TypeFich)
End Sub
Private Sub UserForm_Initialize()
Me.TypeFich.List = Array("*.*", "*.xls", "*.xlsx", "*.mdb", "*.accdb", "*.doc", "*.docx", "*.ppt", "*.pptx")
Me.TypeFich.ListIndex = 0
End Sub

Private Sub commandButton1_Click()
Dim NewSht As Worksheet
Dim MainFolderName As String
Dim TimeLimit As Long, StartTime As Double
Dim nbrLignes As Long

ReDim X(1 To 65536, 1 To 13)

Set objShell = CreateObject("Shell.Application")

MainFolderName = BrowseForFolder()
Set NewSht = ThisWorkbook.Sheets.Add
maDate = Format(Now(), "dd.mm.yy hh mm")
nomUSer = Environ("USERNAME")
NewSht.Name = "Files_" & maDate & " " & nomUSer

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) = "Extension"
X(1, 12) = "Delete Files(y:1/n:0)"
X(1, 13) = "nb codeLines"
i = 1

Dim PosG As Integer
Dim PosH As Integer
Dim Hauteur As Integer
Dim Longueur As Integer
Dim wb As Workbook

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
If (Fil.Name Like Me.TypeFich) Then
Set objFolder = objShell.Namespace(oFolder.Path)
Set objFolderItem = objFolder.ParseName(Fil.Name)
i = i + 1
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) = FSO.GetExtensionName(objFolderItem)
X(i, 12) = 0 'integer
X(i, 13) = 0 ' ici le nombre de lignes de code ....
Dim chemin As String
chemin = "" + oFolder.Path & "\" & Fil.Name
'X(i, 13) = testHasProject(oFolder.Path & "\" & Fil.Name, i)
' If FSO.GetExtensionName(objFolderItem) = "xls" Or FSO.GetExtensionName(objFolderItem) = "xlsx" Then

' Dim chemin As String
' chemin = "" + oFolder.Path & "\" & Fil.Name
'wb = New Workbook
' Set wb = Workbooks.Open(chemin)
' Dim VBProj As VBIDE.VBProject
' Set VBProj = wb.VBProject

' X(i, 13) = TotalLinesInProject(VBProj)
' wb.Close
' End If

End If

Next

'Get subdirectories
Call RecursiveFolder(oFolder, 0)

FastExit:
Range("A:M") = X
If i < 65535 Then Range(Cells(i + 1, "A"), Cells(65536, "A")).EntireRow.Delete
Range("A:M").WrapText = False
Range("A:M").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
Dim wb As Workbook
For Each SubFld In xFolder.SubFolders
Set oFolder = FSO.GetFolder(SubFld)
Set objFolder = objShell.Namespace(SubFld.Path)

For Each Fil In SubFld.Files
If (Fil.Name Like Me.TypeFich) Then
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
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) = FSO.GetExtensionName(objFolderItem)
X(i, 12) = 0
X(i, 13) = 0 ' ici le nombre de lignes de code ....
Dim chemin As String

chemin = "" + oFolder.Path & "\" & Fil.Name
'If FSO.GetExtensionName(objFolderItem) = "xls" Or FSO.GetExtensionName(objFolderItem) = "xlsx" Then
' wb = New Workbook
'
' Set wb = Workbooks.Open(chemin)
' Dim VBProj As VBIDE.VBProject
' Set VBProj = wb.VBProject

' X(i, 13) = TotalLinesInProject(VBProj)
' wb.Close
'
' End If

End If
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
Private Sub CommandButton2_Click()
Unload Me
End Sub