Détecteur de procédures et fonctions inutilisées

Télécharger le projet
Commenter

Description

Cette fonction permet de déterminer pour chaque module les procédures et fonctions qui ne sont pas appelées à partir des formulaires et états et/ou des autres modules dans une base Access

Pré-requis :

- Il faut que le fichier à vérifier soit un mdb
- Dans la base à vérifier référencer la bibliothèque "Visual Basic for Applications Extensibility 5.3"
- Importer la table "TR_ObjetNonTrouve"
- Importer la macro "Rechercher les objets inutiles dans la base"
- Importer le module "RechercheObjetDansBase"
- Lancer la macro "Rechercher les objets inutiles dans la base"

Les résultats seront inscrits dans la table "TR_ObjetNonTrouve"

Source / Exemple : 


Public Function RechercheFonctionDansModule()
'Cette fonction permet de savoir si des fonctions sont utilisées ou non
Dim Momo1 As Module, Momo2 As Module, Nom_Fx As String, Cur_Ligne As Long, Ligne_en_cours As String, Lignes_Fx As Long, Drapeau_Fx As Boolean
Dim Forme As Form, Etat As Report, Reponse As Byte
Dim Fx() As String, a As Integer, b As Integer, c As Long, d As Long
'FX permet d'énumérer le nom des fonctions et procédures des modules.
'Sa structure est la suivante
'La première dimension indique le nom de la fonction ou procédure
'La seconde le nom du module et de la fonction
'La troisième si celle-ci a été trouvée dans un autre module
'Exemple Fx(0,0)="Florent":Fx(1,0)=False

On Error GoTo Erreurs:

Reponse = msgbox("Désirez-vous lancer la recherche des fonctions des modules" & vbCrLf & "- Sur les formulaires, états ET modules [Oui]" & _
vbCrLf & "- Uniquement les formulaires et états [Non] ?", vbYesNo, "Type de recherche des fonctions")
DoCmd.Hourglass True
Drapeau_Fx = False: ReDim Fx(2, 1): c = 0

'On ouvre tous les modules
For a = 0 To CurrentProject.AllModules.Count - 1
    DoCmd.OpenModule CurrentProject.AllModules(a).Name
Next a

For a = 0 To CurrentProject.AllModules.Count - 1
    Set Momo1 = Modules(CurrentProject.AllModules(a).Name)
    
    With Momo1
        Drapeau_Fx = False
        'On détermine le nom des fonctions et procédures
        For Cur_Ligne = .CountOfDeclarationLines + 1 To .CountOfLines
            If Drapeau_Fx = False And UCase(.Lines(Cur_Ligne, 1)) Like "*SUB*(*)*" _
            Or UCase(.Lines(Cur_Ligne, 1)) Like "*FUNCTION*(*)*" Then
                'On insère le nom de la procédure ou fonction et on redimensionne le tableau
                Fx(0, c) = .ProcOfLine(Cur_Ligne, vbext_pk_Proc): Fx(1, c) = "Module " & .Name & "=>" & .ProcOfLine(Cur_Ligne, vbext_pk_Proc): Fx(2, c) = False
                'On passe à la suite
                Cur_Ligne = Cur_Ligne + .ProcCountLines(Fx(0, c), vbext_pk_Proc) - 1
                '-1 car .ProcCountLines positionne le curseur sur la dernière ligne de la fonction
                'Mais, par le Next Cur_Ligne qui suit on loupe la ligne de la fonction suivante
                'si on ne décrémente pas de 1
                c = c + 1
                ReDim Preserve Fx(2, c)
                Drapeau_Fx = True
            Else
                Drapeau_Fx = False
            End If
        Next Cur_Ligne

If Reponse = vbNo Then GoTo 8

        'On regarde dans tous les autres modules pour voir si cette fonction ou procédure est appelée
        For b = 0 To CurrentProject.AllModules.Count - 1 'Dans les autres modules
            Set Momo2 = Modules(CurrentProject.AllModules(b).Name)
            
            With Momo2
                DoCmd.OpenModule .Name
                If .Name <> Momo1.Name Then
                    For d = 0 To UBound(Fx, 2) - 1
                        Do While Fx(2, d) = True 'Pour accélérer le parcours du tableau FX
                            d = d + 1
                            If d = UBound(Fx, 2) Then
                                d = d - 1
                                Exit Do
                            End If
                        Loop
                        If InStr(.Lines(.CountOfDeclarationLines, .CountOfLines), Fx(0, d)) > 0 And Fx(2, d) = False Then Fx(2, d) = True
                    Next d
                End If
            End With
        Next b
        
8       For b = 0 To CurrentProject.AllForms.Count - 1 'Dans les formulaires
            DoCmd.OpenForm CurrentProject.AllForms(b).Name, acDesign
            Set Forme = Forms(CurrentProject.AllForms(b).Name)
            
            With Forme
                For d = 0 To UBound(Fx, 2) - 1
                    Do While Fx(2, d) = True 'Pour accélérer le parcours du tableau FX
                        d = d + 1
                        If d = UBound(Fx, 2) Then
                            d = d - 1
                            Exit Do
                        End If
                    Loop
                
                    If InStr(.Module.Lines(.Module.CountOfDeclarationLines, .Module.CountOfLines), Fx(0, d)) > 0 And Fx(2, d) = False Then Fx(2, d) = True
                Next d
                DoCmd.Close acForm, .Name, acSaveNo
            End With
            
        Next b

        For b = 0 To CurrentProject.AllReports.Count - 1 'Dans les états
            DoCmd.OpenReport CurrentProject.AllReports(b).Name, acViewDesign
            Set Etat = Reports(CurrentProject.AllReports(b).Name)
            With Etat
                For d = 0 To UBound(Fx, 2) - 1
                    Do While Fx(2, d) = True 'Pour accélérer le parcours du tableau FX
                        d = d + 1
                        If d = UBound(Fx, 2) Then
                            d = d - 1
                            Exit Do
                        End If
                    Loop
                    If InStr(.Module.Lines(.Module.CountOfDeclarationLines, .Module.CountOfLines), Fx(0, d)) > 0 And Fx(2, d) = False Then Fx(2, d) = True
                Next d
                DoCmd.Close acReport, .Name, acSaveNo
            End With
        Next b

    End With
10  Next a

'Arrivé à ce stade, toutes les valeurs Fx(1,x) en False signifient que les procédures et fonctions F(0,x) ne sont sollicitée nulle part
'On les écrit dans la table
For a = 0 To UBound(Fx, 2) - 1
    If Fx(2, a) = False Then DoCmd.RunSQL "INSERT INTO TR_ObjetNonTrouve (Type,Nom) VALUES('FUNCTION ou SUB','" & Fx(1, a) & "')"
Next a

'On ferme tous les modules
For a = 0 To CurrentProject.AllModules.Count - 1
    DoCmd.Close acModule, CurrentProject.AllModules(a).Name, acSaveNo
Next a

DoCmd.Hourglass False
Exit Function

Erreurs:
If Err.Number = 7784 Then
'Erreur qui signifie qu'un sous formulaire a déja été ouvert par un formulaire
Resume Next
ElseIf Err.Number = 17 Then 'On ne peut pas fermer ce module car il n'a pas fini d'exécuter la fonction
Resume Next
Else
msgbox Err.Description, vbCritical, "Erreur N° " & Err.Number
Resume Next
End If
End Function
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (cs_8Tnerolf8)