1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95
|
Option Explicit
Function Audit() As Boolean
Dim MyWorkbook As Workbook
Dim MySheet As Worksheet
Dim VBCodeMod As CodeModule
Dim MyComponent As VBComponent
Dim ProcType As VBIDE.vbext_ProcKind
Dim StrNomProc As String
Dim StrTypeProc As String
Dim LngStartProc As Long
Dim LngEndProc As Long
Dim StrContenuFonction As String
Dim StrChaineCherchee As String
Dim MaLigneCode As String
' Dim ArrResume()
Dim LngCpt As Long
Dim LngLigne As Long
Dim StartLine As Long
On Error GoTo erreur
Set MyWorkbook = ActiveWorkbook
' Set MyWorkbook = Application.Workbooks("")
Set MySheet = MyWorkbook.Sheets(1)
StrChaineCherchee = "on error resume next"
LngLigne = 1
For Each MyComponent In MyWorkbook.VBProject.VBComponents
'On recupere le type du composant
Select Case MyComponent.Type
Case vbext_ct_StdModule
StrTypeProc = "Module"
Case vbext_ct_ClassModule
StrTypeProc = "Class"
Case vbext_ct_Document
StrTypeProc = "Feuille"
Case vbext_ct_MSForm
StrTypeProc = "UserForm"
End Select
Set VBCodeMod = MyWorkbook.VBProject.VBComponents(MyComponent.Name).CodeModule
'On récupère la taille de la procédure
With VBCodeMod
StrNomProc = VBCodeMod.ProcOfLine(1, ProcType)
If StrNomProc <> "" Then
StartLine = 1 '.CountOfLines + 1
StrNomProc = VBCodeMod.ProcOfLine(StartLine, ProcType)
'On recherche le type de la procédure
MaLigneCode = .Lines(StartLine, 1)
'On récupère le nom de la fonction et son type
LngStartProc = VBCodeMod.ProcBodyLine(StrNomProc, ProcType) + 1
LngEndProc = .ProcStartLine(StrNomProc, ProcType) + .ProcCountLines(StrNomProc, ProcType) - 2
LngCpt = StartLine
Do Until LngLigne >= LngEndProc
********** MON problème est à ce niveau... **********
StrContenuFonction = LTrim(VBCodeMod.Lines(LngCpt, 1))
********** MON problème est à ce niveau... **********
If InStr(1, StrChaineCherchee, StrContenuFonction) Then
MySheet.Range("A" & LngLigne) = MyComponent.Name
MySheet.Range("B" & LngLigne) = StrNomProc
MySheet.Range("C" & LngLigne) = StrTypeProc
MySheet.Range("D" & LngLigne) = StrChaineCherchee
LngLigne = LngLigne + 1
End If
LngCpt = LngCpt + 1
Loop
End If
End With
Next
erreur:
Resume
Set MyWorkbook = Nothing
End Function |
Partager