A voir également:
- Utiliser fichier fermé pour récupérer nbr code lines
- Fichier rar - Guide
- Fichier host - Guide
- Fichier iso - Guide
- Recuperer video youtube - Guide
- Comment récupérer un compte facebook piraté - Guide
1 réponse
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
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
