utiliser fichier fermé pour récupérer nbr code lines Fermé

Question

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.


Configuration: Windows 7 / Chrome 34.0.1847.131

mirou85 · Answer

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

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

1 réponse

Discussions similaires