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

mirou85 -  
 mirou85 -
Bonjour,


Je suis débutante et voudrais savoir par quoi compketer cette ligne" Extended Properties=Excel .." si je travaille avec excel 2013 et s'il serait possible d'utiliser ADO non pas pour lire et écrire dans le fichier excel fermé mais pour récupérer le nombre de lignes DE CODE VBA s'il y en a.
en effet, ma macro liste dans une feuille excel tous les fichiers d'un répertoire et de ses sous repertoires et je replis les colonnes avec les propriétés de chaque fichier.... il hy a différents types de fichiers (mdb, xls, xlsx, accdb,txt...) et je n'arrive pas à remplir la colonne "Nombre de lignes de code VBA".
Merci d'avance pour votre aide.


A voir également:

1 réponse

Réponse 1 / 1
mirou85
 
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
0

Discussions similaires

Colis shein terminal fret
Lele -
bazfile -

1 réponse