Option Explicit
Dim NomModule As String
Dim NomProc As String
Dim TypeProcedure As vbext_ProcKind
Dim LigneStartProc As Long
Dim LigneBodyProc As Long
Dim NbLignesProc As Long
Dim CodeContenu As String
Dim CodeDeclaration As String
Dim TypeDeclaration As String
Dim ListeVarInuProc As String, ListeVarInuModule As String
Dim NbInutile As Integer
Dim TabDimEc() As String, ITabDimEc As Integer
Dim TabDimEcc() As String, ITabDimEcc As Integer, ITabDimEcc2 As Integer
Dim TabDimEccVide As Boolean
Sub ListerComposantsClasseurs()
' Liste des composanst des classeurs ouverts
Dim DerLigne As Long, DerColonne As Long
Dim VBComp As VBComponent
Dim i As Integer
Dim WorkBookCourant As Workbook
With Sheets("Variables Inutilisées")
DerLigne = .Cells(.Rows.Count, .Range("A2").Column).End(xlUp).Row
DerColonne = .Cells(.Range("A1").Row, .Columns.Count).End(xlToLeft).Column
Application.EnableEvents = False
.Range(.Range("A2"), .Cells(DerLigne, DerColonne)).ClearContents
Application.EnableEvents = True
i = 2
For Each WorkBookCourant In Workbooks
For Each VBComp In WorkBookCourant.VBProject.VBComponents
.Cells(i, 1) = WorkBookCourant.Name
.Cells(i, 2) = VBComp.Name
i = i + 1
Next VBComp
Next WorkBookCourant
End With
End Sub
Sub LancerAnalyseCodeVarInu()
' Demande d'analyse pour un module d'un Classeur OUVERT
' de la ligne sélectionnée dans la feuille
With ActiveSheet
AnalyseCodeVarInu .Cells(ActiveCell.Row, 1), .Cells(ActiveCell.Row, 2)
End With
End Sub
Sub AnalyseCodeVarInu(pNomClasseur As String, pNomModule As String)
' Fonctionne pour les Variables déclarées Dim dans le Module
' Il y aura besoin de code supplémentaire pour des variables :
' Public, Private, Static, Array, Type ... End Type
Dim Titre As String
Dim Message As String
Dim Debut As Long
Dim i As Integer, j As Integer
Titre = "Analyse des variables (Dim) inutilisées dans un Module"
'On analyse uniquement les variables déclarées Dim
TypeDeclaration = "Dim "
NomModule = pNomModule
NbInutile = 0
With Workbooks(pNomClasseur).VBProject.VBComponents(NomModule).CodeModule
TabDimEccVide = True
'Déclarations du Module
'----------------------
NomProc = ""
NbLignesProc = .CountOfDeclarationLines
If NbLignesProc > 0 Then
CodeDeclaration = .Lines(1, .CountOfDeclarationLines) & vbLf
MajTableauDimProcedure CodeDeclaration
End If
' Déclarations de Chaque Procédure
'---------------------------------
'positionnement après la partie Déclarations du Module
Debut = .CountOfDeclarationLines + 1
Do Until Debut >= .CountOfLines
NomProc = .ProcOfLine(Debut, TypeProcedure)
LigneBodyProc = .ProcBodyLine(NomProc, TypeProcedure)
NbLignesProc = .ProcCountLines(NomProc, TypeProcedure)
CodeContenu = .Lines(LigneBodyProc, NbLignesProc)
MajTableauDimProcedure CodeContenu
Debut = Debut + NbLignesProc + 1
Loop
' liste des Variables Dim du Module (nom procédure - nom variable)
If ITabDimEcc > 0 Then
For ITabDimEcc = LBound(TabDimEcc, 2) To UBound(TabDimEcc, 2)
Message = Message & TabDimEcc(0, ITabDimEcc) & " - " & TabDimEcc(1, ITabDimEcc) & vbLf
Next ITabDimEcc
Else
Message = "Aucune variable déclarée !"
MsgBox Message, vbInformation, "Liste des variables du Module" & NomModule
GoTo FinTraitement
End If
' Pour afficher la Liste des variables déclarées
MsgBox Message, vbInformation, "Liste des variables du Module" & NomModule
'Analyse des Déclarations du Module
'----------------------------------
ListeVarInuProc = ""
NomProc = ""
LigneStartProc = 1
LigneBodyProc = 1
NbLignesProc = .CountOfDeclarationLines
If NbLignesProc > 0 Then
CodeContenu = .Lines(1, .CountOfLines)
AnalyseCodeVarInuProcedure True, CodeContenu
End If
ListeVarInuModule = "--- Déclarations du Module" & vbLf
If ListeVarInuProc = "" Then ListeVarInuModule = ListeVarInuModule & "Aucune" Else ListeVarInuModule = ListeVarInuModule & ListeVarInuProc
'Analyse des Déclarations de Chaque Procédure
'--------------------------------------------
'positionnement après la partie Déclarations du Module
Debut = .CountOfDeclarationLines + 1
Do Until Debut >= .CountOfLines
ListeVarInuProc = ""
NomProc = .ProcOfLine(Debut, TypeProcedure)
LigneStartProc = .ProcStartLine(NomProc, TypeProcedure)
LigneBodyProc = .ProcBodyLine(NomProc, TypeProcedure)
NbLignesProc = .ProcCountLines(NomProc, TypeProcedure)
CodeContenu = .Lines(LigneBodyProc, NbLignesProc)
AnalyseCodeVarInuProcedure False, CodeContenu
Debut = Debut + NbLignesProc + 1
ListeVarInuModule = ListeVarInuModule & vbLf & "--- Déclarations de la Procédure " & NomProc & vbLf
If ListeVarInuProc = "" Then ListeVarInuModule = ListeVarInuModule & "Aucune" Else ListeVarInuModule = ListeVarInuModule & ListeVarInuProc
Loop
' Pour afficher la Liste des variables inutilisées dans tout le module
'MsgBox ListeVarInuModule, vbInformation, "Liste de toutes les variables inutilisées du Module" & NomModule
Debug.Print "-----------------------------------------------------------------------------------------------------------"
Debug.Print " Liste de toutes les variables inutilisées du Module" & NomModule & " du classeur " & pNomClasseur
Debug.Print "-----------------------------------------------------------------------------------------------------------"
Debug.Print ListeVarInuModule
FinTraitement:
If ITabDimEcc > 0 Then
Message = "Analyse du Code du Module " & pNomModule & " du classeur " & pNomClasseur & " terminée." & vbLf _
& NbInutile & " variables inutilisées." & vbLf _
& "Voir la fenêtre Exécution de l'éditeur VBE"
Else
Message = "Analyse du Code du Module " & pNomModule & " du classeur " & pNomClasseur & " terminée." & vbLf _
& "Aucune variable déclarée !"
End If
MsgBox Message, vbInformation, Titre
End With
End Sub
Sub MajTableauDimProcedure(pCodeDeclaration As String)
Dim TabCodeDeclaration() As String
Dim ChaineDim As String
Dim TabDim() As String, ITabDim As Integer
Dim i As Integer, j As Integer
Dim Pos As Integer
' Préparation des tableaux de déclarations Dim
'---------------------------------------------
TabCodeDeclaration = Split(pCodeDeclaration, vbLf)
'la dernière ligne est vide
ReDim Preserve TabCodeDeclaration(0 To UBound(TabCodeDeclaration) - 1)
For i = LBound(TabCodeDeclaration) To UBound(TabCodeDeclaration)
' on enlève les espaces de gauche
TabCodeDeclaration(i) = LTrim(TabCodeDeclaration(i))
' on enlève le saut de ligne
If Len(TabCodeDeclaration(i)) <> 0 And i < UBound(TabCodeDeclaration) - LBound(TabCodeDeclaration) Then
TabCodeDeclaration(i) = Left(TabCodeDeclaration(i), Len(TabCodeDeclaration(i)) - 1)
End If
If Left(LTrim(TabCodeDeclaration(i)), Len(TypeDeclaration)) = TypeDeclaration Then
' Ligne Dim
If ChaineDim = "" Then ChaineDim = TabCodeDeclaration(i) Else ChaineDim = ChaineDim & vbLf & TabCodeDeclaration(i)
End If
Next i
' TabDim contient toutes les déclarations Dim : "Dim xxx"
TabDim = Split(ChaineDim, vbLf)
' Contrôle du contenu à partir des tableaux de déclarations Dim
'--------------------------------------------------------------
For ITabDim = LBound(TabDim) To UBound(TabDim)
' ici on éclate les déclarations multiples sur la même e lignes en x lignes
' on élimine ce qui est en commentaire car il peut y avoir par exemple "Dim Var 1 ' Dim Var2"
Pos = InStr(TabDim(ITabDim), "'")
If Pos <> 0 Then
TabDim(ITabDim) = Left(TabDim(ITabDim), Pos - 1)
End If
TabDimEc = Filter(Split(Replace(Replace(TabDim(ITabDim), "Dim ", "Dim µ"), ", ", " µ")), "µ")
ITabDimEc = 0
For i = LBound(TabDimEc) To UBound(TabDimEc)
ITabDimEc = ITabDimEc + 1
TabDimEc(i) = Replace(TabDimEc(i), "µ", "")
If InStr(TabDimEc(i), "(") <> 0 Then
' Variable Tableau
' -> pour détecter l'utilisation dans le code on testera "Var(" et "Var"
TabDimEc(i) = Left(TabDimEc(i), InStr(TabDimEc(i), "(") - 1)
End If
Next i
If ITabDimEc > 0 Then
'tableau TabDimEc non vide
If TabDimEccVide Then
ITabDimEcc = 0
ReDim TabDimEcc(1, UBound(TabDimEc) - LBound(TabDimEc))
TabDimEccVide = False
Else
ITabDimEcc = UBound(TabDimEcc, 2) + 1
ReDim Preserve TabDimEcc(1, UBound(TabDimEcc, 2) + UBound(TabDimEc) + 1)
End If
For i = LBound(TabDimEc) To UBound(TabDimEc)
TabDimEcc(0, ITabDimEcc) = NomProc
TabDimEcc(1, ITabDimEcc) = TabDimEc(i)
ITabDimEcc = ITabDimEcc + 1
Next i
End If
Next ITabDim
End Sub
Sub AnalyseCodeVarInuProcedure(pDeclarationModule As Boolean, pCodeContenu As String)
Dim TabCodeContenu() As String
Dim TabDim() As String, ITabDim As Integer
Dim ChaineSansCom As String
Dim TabSansCom() As String, ITabSansCom As Integer
Dim i As Integer
Dim ChaineW As String
Dim Pos As Integer, Pos2 As Integer
Dim Absent As Boolean
Dim TrouveMot As Boolean
Dim LigneProcedureCourante As String
Dim NbOcc As Integer
Dim Fin As Boolean
' Analyse variables (pour le moment seulement Dim)
'-------------------
' Tableau du contenu sans Dim et sans les lignes commentaires
'---------------------------------------------
ChaineSansCom = ""
TabCodeContenu = Split(pCodeContenu, vbLf)
For i = LBound(TabCodeContenu) To UBound(TabCodeContenu)
If Len(TabCodeContenu(i)) <> 0 And i <> UBound(TabCodeContenu) Then TabCodeContenu(i) = Left(TabCodeContenu(i), Len(TabCodeContenu(i)) - 1)
If Left(LTrim(TabCodeContenu(i)), Len(TypeDeclaration)) <> TypeDeclaration Then
If Left(LTrim(TabCodeContenu(i)), 1) <> "'" Then
If ChaineSansCom = "" Then ChaineSansCom = TabCodeContenu(i) Else ChaineSansCom = ChaineSansCom & vbLf & TabCodeContenu(i)
End If
End If
Next i
' élimination des lignes commentaires
TabSansCom = Split(ChaineSansCom, vbLf)
' Contrôle du contenu à partir du tableau de déclarations Dim
'--------------------------------------------------------------
LigneProcedureCourante = ""
' liste des Variables Dim du Module (nom procédure - nom variable
For ITabDimEcc = LBound(TabDimEcc, 2) To UBound(TabDimEcc, 2)
'on ne considère que les variables déclarées dans la procédure courante (NomProc ="" pour les déclarations de niveau module
If TabDimEcc(0, ITabDimEcc) = NomProc Then
Absent = True
For ITabSansCom = LBound(TabSansCom) To UBound(TabSansCom)
If pDeclarationModule Then
'on mémorise le nom de la procédure courante
ChaineW = MemoProcCourante(LTrim(TabSansCom(ITabSansCom)))
If ChaineW <> "" Then LigneProcedureCourante = ChaineW
End If
' Recherche de toutes les occurences de présence de la variable courante dans la ligne de code courante
' On examine toutes les coccurrences jusqu'à ce que une soit correcte
' - Pas en commentaire
' - Pas encadrée par ""
Pos = InStr(TabSansCom(ITabSansCom), TabDimEcc(1, ITabDimEcc))
If Pos = 0 Then
Fin = True
Else
ChaineW = TabSansCom(ITabSansCom)
Fin = False
End If
While Not Fin
If EstMot(ChaineW, TabDimEcc(1, ITabDimEcc), Pos) Then
' Pos contient la position de la variable dans la ligne courante
' on regarde si trouvé en dehors d'une zone commentaire
ChaineW = Mid(ChaineW, Pos, Len(ChaineW))
Pos2 = InStr(ChaineW, "'")
If Pos2 <> 0 Then
' on a trouvé le caractère ' sur la ligne
If ChaineEntreApostrophes(ChaineW, "'") Then
'le caractère ' est encadré par "" -> ce n'est donc pas commentaire
'on regarde si variable encadré par ""
Absent = ChaineEntreApostrophes(ChaineW, TabDimEcc(1, ITabDimEcc))
'''If Not Absent Then Exit For
End If
Else
'pas dans zone commentaire
'on regarde si encadré par ""
Absent = ChaineEntreApostrophes(ChaineW, TabDimEcc(1, ITabDimEcc))
End If
If Absent Then
'on cherche l'occurence suivante dans la ligne
ChaineW = Mid(ChaineW, Pos, Len(ChaineW))
If ChaineW = "" Then Fin = True
Else
Fin = True
End If
Else
Fin = True
End If
Wend
If Not Absent Then
If Not pDeclarationModule Then
Exit For
Else
' Variable de Niveau Module
' La variable est utilisée dans une procédure mais il faut vérifier qu'elle n'est pas aussi déclarée dans la procédure
For ITabDimEcc2 = LBound(TabDimEcc, 2) To UBound(TabDimEcc, 2)
If LigneProcedureCourante <> "" _
And (TabDimEcc(0, ITabDimEcc2) = LigneProcedureCourante) _
And (TabDimEcc(1, ITabDimEcc2) = TabDimEcc(1, ITabDimEcc)) Then
' La variable est utilisée dans la procédure mais elle est aussi déclarée dans la procédure
Absent = True
End If
Next ITabDimEcc2
If Not Absent Then Exit For
End If
End If
Next ITabSansCom
If Absent Then
NbInutile = NbInutile + 1
' pour le Debug.Print
If ListeVarInuProc = "" Then ListeVarInuProc = ListeVarInuProc & TabDimEcc(1, ITabDimEcc) Else ListeVarInuProc = ListeVarInuProc & vbLf & TabDimEcc(1, ITabDimEcc)
End If
End If
Next ITabDimEcc
End Sub
Function MemoProcCourante(Pchaine As String) As String
MemoProcCourante = ""
Select Case True
Case Pchaine Like "Private Sub*"
MemoProcCourante = Mid(Pchaine, Len("Private Sub*") + 1)
MemoProcCourante = Left(MemoProcCourante, InStr(MemoProcCourante, "(") - 1)
Case Pchaine Like "Private Function*"
MemoProcCourante = Mid(Pchaine, Len("Private Function*") + 1)
MemoProcCourante = Left(MemoProcCourante, InStr(MemoProcCourante, "(") - 1)
Case Pchaine Like "Sub*"
MemoProcCourante = Mid(Pchaine, Len("Sub*") + 1)
MemoProcCourante = Left(MemoProcCourante, InStr(MemoProcCourante, "(") - 1)
Case Pchaine Like "Function*"
MemoProcCourante = Mid(Pchaine, Len("Function*") + 1)
MemoProcCourante = Left(MemoProcCourante, InStr(MemoProcCourante, "(") - 1)
End Select
End Function
Function ChaineEntreApostrophes(Pchaine As String, pRech As String) As Boolean
'on regarde si encadré par ""
Dim ChaineW As String
Dim Pos As Long, Pos2 As Long
Dim Absent As Boolean
Dim Fin As Boolean
ChaineEntreApostrophes = True
Pos = InStr(Pchaine, pRech)
Pos2 = InStr(Pchaine, """")
If Pos2 < Pos Then
' le premier " est situé avant, on va regarder où est le suivant
ChaineW = Mid(Pchaine, Pos2 + 1, Len(Pchaine))
Fin = False
While Not Fin
Pos = InStr(ChaineW, pRech)
Pos2 = InStr(ChaineW, """")
Select Case True
Case Pos = 0
' Var non trouvée hors zone commentaire
Fin = True
Case Pos2 = 0 And Pos <> 0
' pas de 2ème "
ChaineEntreApostrophes = False
Fin = True
Case Else
' 2ème " avant ou après la variable -> on avance
ChaineW = Mid(ChaineW, Pos2 + 1, Len(ChaineW))
End Select
Wend
Else
ChaineEntreApostrophes = False
End If
End Function
Function EstMot(Pchaine As String, pRech As String, ByRef pPosMot As Integer)
' pPosMot contient la position du MOT pRech trouvé dans pChaine
'''Const SEPARATEUR = " [.!#$%&'*/=?^_`{|} ~+-]"
Const SEPARATEUR = " ,()"
Dim i As Integer
Dim Pos As Integer, PosSuiv As Integer
Dim Fin As Boolean
Dim ChaineW As String
Dim AvantOk As Boolean
EstMot = False
ChaineW = Pchaine
pPosMot = 0
Fin = False
While Not Fin
Pos = InStr(ChaineW, pRech)
PosSuiv = Pos + Len(pRech)
AvantOk = False
Select Case Pos
Case 0
Fin = True
Case 1
'pas de caractère précédent
AvantOk = True
Case Else
For i = 1 To Len(SEPARATEUR)
If Mid(ChaineW, Pos - 1, 1) = Mid(SEPARATEUR, i, 1) Then
'Caractère précédent est un signe de mot
AvantOk = True
Exit For
End If
Next i
End Select
If AvantOk Then
If PosSuiv > Len(ChaineW) Then
EstMot = True
Else
For i = 1 To Len(SEPARATEUR)
If Mid(ChaineW, PosSuiv, 1) = Mid(SEPARATEUR, i, 1) Then
'Caractère suivant est un signe de mot
EstMot = True
Exit For
End If
Next i
End If
End If
If Not EstMot Then
ChaineW = Mid(ChaineW, PosSuiv, Len(ChaineW))
pPosMot = pPosMot + PosSuiv - 1
If ChaineW = "" Then Fin = True
Else
pPosMot = pPosMot + PosSuiv - Len(pRech)
Fin = True
End If
Wend
If Not EstMot Then pPosMot = 0
End Function
