Lister les fonctions et procédures d'une base Access

Version imprimable

Bonjour à tous,
suite à un besoin de visibilité des fonctions et procédures existantes dans nos bases Access, j'ai développé cette fonction qui récupère en paramètre le path d'une base access, et alimente une table T_LISTE_PROCEDURES, contenant les champs suivants :

Citation:

tous les champs sont de type texte
- DB_PATH : path de la base Access
- FUNCTION_OR_SUB : définit s'il s'agit d'une procédure ou d'une fonction
- NM_FUNCTION_OR_SUB : nom de la procédure/fonction
- PARAM : liste des paramètres
- RETURN : dans le cas des fonctions, spécifit le type de retour

Code:

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
Function Liste_Procedures_Fonctions_VBA(pathbase As String) As Boolean
Dim strSQL As String
Dim Accmodule As Module
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim Cible As String
Dim oAccess As New Access.Application
Dim oDb As DAO.Database
 
'On Error GoTo fin
 
 
    With oAccess
        .Visible = False
        .OpenCurrentDatabase (pathbase)
        Set oDb = .CurrentDb
    End With
 
    For i = 1 To oAccess.VBE.VBProjects(1).VBComponents.Count
        With oAccess.VBE.VBProjects(1).VBComponents.item(i).CodeModule
        ' pour le remplacement d'une ligne entière
            For k = 1 To .CountOfLines
                Cible = .Lines(k, 1)
                'Debug.Print Cible
                If Left(Cible, 1) <> "'" Then
                    If InStr(1, Cible, "Function ") > 0 Then
                        CurrentDb.Execute "INSERT INTO T_LISTE_PROCEDURES (DB_PATH,FUNCTION_OR_SUB,NM_FUNCTION_OR_SUB,PARAM,RETURN) VALUES ('" & pathbase & "','Function','" & RecupererTexteEntreBornes(Cible, "Function ", "(") & "','" & RecupererTexteEntreBornes(Cible, "(", ")") & "','" & RecupererTexteEntreBornes(Cible, ") As ", "") & "')"
                    End If
                    If InStr(1, Cible, "Sub ") > 0 Then
                        CurrentDb.Execute "INSERT INTO T_LISTE_PROCEDURES (DB_PATH,FUNCTION_OR_SUB,NM_FUNCTION_OR_SUB,PARAM) VALUES ('" & pathbase & "','Sub','" & RecupererTexteEntreBornes(Cible, "Sub ", "(") & "','" & RecupererTexteEntreBornes(Cible, "(", ")") & "')"
                    End If
                End If
            Next k
        End With
    Next i
    CurrentDb.Execute "UPDATE T_LISTE_PROCEDURES SET PARAM = '' WHERE Left(PARAM,1)=')'"
    oDb.Close
    oAccess.DoCmd.Close , , acSaveYes
    Set oAccess = Nothing
    Set oDb = Nothing
    Liste_Procedures_Fonctions_VBA = True
Exit Function
 
fin:
    Liste_Procedures_Fonctions_VBA = False
    Resume Next
End Function
 
'Fonction utilisée pour récuperer un texte compris entre deux autres
'exemple : RecupererTexteEntreBornes("<html><body>Pioupi</body></html>","<body>","</body>") 
'retournera Pioupi
Function RecupererTexteEntreBornes(texte As String, textedebut As String, textefin As String) As String
Dim result As String
Dim debut As Integer
Dim fin As Integer
    debut = InStr(1, texte, textedebut)
    fin = InStr(debut + Len(textedebut), texte, textefin)
    result = ""
    If debut > 0 Then
        If fin > debut + Len(textedebut) Then
            result = Mid(texte, debut + Len(textedebut), fin - debut - Len(textedebut))
        Else
            result = Right(texte, Len(texte) - debut - Len(textedebut) + 1)
        End If
    End If
    RecupererTexteEntreBornes = result
End Function

Cette fonction peut-être encore implémentée (portée de la fonction/procédure, nb de ligne de codes, etc.), aussi ferais-je des ajouts progressivement.

De même, si l'utilisation d'une telle fonction intéresse certaines personnes parmi les forumeurs, je suis prêt à en faire un article :oops:

Suite aux conseils de Vodiem (que je salue :bonjour:),
voici déjà la création de la table qui récupère les données :

Code:

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
Public Sub pCreateTable()
 
    Dim Db As Database
    Dim tblTable As TableDef
    Dim fldTemp As Field
 
    Set Db = CurrentDb()
    If DoesTableExist("T_LISTE_PROCEDURES") Then Db.Execute ("DROP TABLE T_LISTE_PROCEDURES")
 
    ' Description et création des attributs de la table
    Set tblTable = Db.CreateTableDef("T_LISTE_PROCEDURES")
 
    With tblTable
        Set fldTemp = .CreateField("DB_PATH", dbText)
        fldTemp.Required = False
        fldTemp.AllowZeroLength = True
        .Fields.Append fldTemp
 
        Set fldTemp = .CreateField("FUNCTION_OR_SUB", dbText)
        fldTemp.Required = False
        fldTemp.AllowZeroLength = True
        .Fields.Append fldTemp
 
        Set fldTemp = .CreateField("NM_FUNCTION_OR_SUB", dbText)
        fldTemp.Required = False
        fldTemp.AllowZeroLength = True
        .Fields.Append fldTemp
 
        Set fldTemp = .CreateField("PARAM", dbText)
        fldTemp.Required = False
        fldTemp.AllowZeroLength = True
        .Fields.Append fldTemp
 
        Set fldTemp = .CreateField("RETURN", dbText)
        fldTemp.Required = False
        fldTemp.AllowZeroLength = True
        .Fields.Append fldTemp
    End With
 
    Db.TableDefs.Append tblTable
End Sub
 
'*****************************
'fonction de test d'existence d'une table par les propriétés VBA
'input = nom de la table
'output = booleen
'*****************************
Function DoesTableExist(ByVal NomTable As String) As Boolean
    Dim str As String
    On Error GoTo NoTable
    str = CurrentDb.TableDefs(NomTable).Name
    DoesTableExist = True
    Exit Function
NoTable:
    Select Case err.Number
        Case 3265
            DoesTableExist = False
    End Select
End Function

Le code "complet" devient donc :

Code:

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
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
Function Liste_Procedures_Fonctions_VBA(pathbase As String) As Boolean
Dim strSQL As String
Dim Accmodule As Module
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim Cible As String
Dim oAccess As New Access.Application
Dim oDb As DAO.Database
 
On Error GoTo fin
 
 
    With oAccess
        .Visible = False
        .OpenCurrentDatabase (pathbase)
        Set oDb = .CurrentDb
    End With
    pCreateTable
    For i = 1 To oAccess.VBE.VBProjects(1).VBComponents.Count
        With oAccess.VBE.VBProjects(1).VBComponents.item(i).CodeModule
        ' pour le remplacement d'une ligne entière
            For k = 1 To .CountOfLines
                Cible = .Lines(k, 1)
                'Debug.Print Cible
                If Left(Cible, 1) <> "'" Then
                    If InStr(1, Cible, "Function ") > 0 Then
                        CurrentDb.Execute "INSERT INTO T_LISTE_PROCEDURES (DB_PATH,FUNCTION_OR_SUB,NM_FUNCTION_OR_SUB,PARAM,RETURN) VALUES ('" & pathbase & "','Function','" & RecupererTexteEntreBornes(Cible, "Function ", "(") & "','" & RecupererTexteEntreBornes(Cible, "(", ")") & "','" & RecupererTexteEntreBornes(Cible, ") As ", "") & "')"
                    End If
                    If InStr(1, Cible, "Sub ") > 0 Then
                        CurrentDb.Execute "INSERT INTO T_LISTE_PROCEDURES (DB_PATH,FUNCTION_OR_SUB,NM_FUNCTION_OR_SUB,PARAM) VALUES ('" & pathbase & "','Sub','" & RecupererTexteEntreBornes(Cible, "Sub ", "(") & "','" & RecupererTexteEntreBornes(Cible, "(", ")") & "')"
                    End If
                End If
            Next k
        End With
    Next i
    CurrentDb.Execute "UPDATE T_LISTE_PROCEDURES SET PARAM = '' WHERE Left(PARAM,1)=')'"
    oDb.Close
    oAccess.DoCmd.Close , , acSaveYes
    Set oAccess = Nothing
    Set oDb = Nothing
    Liste_Procedures_Fonctions_VBA = True
Exit Function
 
fin:
    Liste_Procedures_Fonctions_VBA = False
    Resume Next
End Function
 
'Fonction utilisée pour récuperer un texte compris entre deux autres
'exemple : RecupererTexteEntreBornes("<html><body>Pioupi</body></html>","<body>","</body>") 
'retournera Pioupi
Function RecupererTexteEntreBornes(texte As String, textedebut As String, textefin As String) As String
Dim result As String
Dim debut As Integer
Dim fin As Integer
    debut = InStr(1, texte, textedebut)
    fin = InStr(debut + Len(textedebut), texte, textefin)
    result = ""
    If debut > 0 Then
        If fin > debut + Len(textedebut) Then
            result = Mid(texte, debut + Len(textedebut), fin - debut - Len(textedebut))
        Else
            result = Right(texte, Len(texte) - debut - Len(textedebut) + 1)
        End If
    End If
    RecupererTexteEntreBornes = result
End Function
 
 
Public Sub pCreateTable()
 
    Dim Db As Database
    Dim tblTable As TableDef
    Dim fldTemp As Field
 
    Set Db = CurrentDb()
    If DoesTableExist("T_LISTE_PROCEDURES") Then Db.Execute ("DROP TABLE T_LISTE_PROCEDURES")
 
    ' Description et création des attributs de la table
    Set tblTable = Db.CreateTableDef("T_LISTE_PROCEDURES")
 
    With tblTable
        Set fldTemp = .CreateField("DB_PATH", dbText)
        fldTemp.Required = False
        fldTemp.AllowZeroLength = True
        .Fields.Append fldTemp
 
        Set fldTemp = .CreateField("FUNCTION_OR_SUB", dbText)
        fldTemp.Required = False
        fldTemp.AllowZeroLength = True
        .Fields.Append fldTemp
 
        Set fldTemp = .CreateField("NM_FUNCTION_OR_SUB", dbText)
        fldTemp.Required = False
        fldTemp.AllowZeroLength = True
        .Fields.Append fldTemp
 
        Set fldTemp = .CreateField("PARAM", dbText)
        fldTemp.Required = False
        fldTemp.AllowZeroLength = True
        .Fields.Append fldTemp
 
        Set fldTemp = .CreateField("RETURN", dbText)
        fldTemp.Required = False
        fldTemp.AllowZeroLength = True
        .Fields.Append fldTemp
    End With
 
    Db.TableDefs.Append tblTable
End Sub
 
'*****************************
'fonction de test d'existence d'une table par les propriétés VBA
'input = nom de la table
'output = booleen
'*****************************
Function DoesTableExist(ByVal NomTable As String) As Boolean
    Dim str As String
    On Error GoTo NoTable
    str = CurrentDb.TableDefs(NomTable).Name
    DoesTableExist = True
    Exit Function
NoTable:
    Select Case err.Number
        Case 3265
            DoesTableExist = False
    End Select
End Function

Citation:
Envoyé par Tofalu
Salut,

On ne pourrais pas éviter :

Code:

CurrentDb.Execute "UPDATE T_LISTE_PROCEDURES SET PARAM = '' WHERE Left(PARAM,1)=')'"

Parce que là on retravaille sur toute la table en y appliquant un WHERE pour rien puisqu'à priori on pourrait très bien gérer PARAM à l'insertion.
Code:

1 2 3 4 5 6 If InStr(1, Cible, "Function ") > 0 Then CurrentDb.Execute "INSERT INTO T_LISTE_PROCEDURES (DB_PATH,FUNCTION_OR_SUB,NM_FUNCTION_OR_SUB,PARAM,RETURN) VALUES ('" & pathbase & "','Function','" & RecupererTexteEntreBornes(Cible, "Function ", "(") & "','" & RecupererTexteEntreBornes(Cible, "(", ")") & "','" & RecupererTexteEntreBornes(Cible, ") As ", "") & "')" End If If InStr(1, Cible, "Sub ") > 0 Then CurrentDb.Execute "INSERT INTO T_LISTE_PROCEDURES (DB_PATH,FUNCTION_OR_SUB,NM_FUNCTION_OR_SUB,PARAM) VALUES ('" & pathbase & "','Sub','" & RecupererTexteEntreBornes(Cible, "Sub ", "(") & "','" & RecupererTexteEntreBornes(Cible, "(", ")") & "')" End If
On peut faire un if else end if, plutot que 2 if ;)

Une amélioration possible, utiliser des requêtes paramétrées pour les insert histoire de rendre le code plus digeste ;)

Ca aurait bien sa place dans les codes sources, il n'y a pas d'équivalent je crois ;)

12/01/2009, 18h41
Jean-Philippe André

Tout à fait,
il y a même des subtilités pour lesquelles je n'ai pas encore cherché de "bidouilles" ni de correctifs :
- nom de fonction/procédure finissant par Sub ou Function (exemple PseudoFunction ou BidonSub), car pouvant apparaitre lors de l'appel de la dite fonction.

Concernant la portée de la procédure/fonction, j'ai fait un bout de code qui le gère, je suis actuellement sur la proposition de vodiem : détection de fonction / procédure non utilisée.:aie:

Salut à tous,

C'est une coincidence peut-être, mais j'ai travaillé quelques mois pour me faire des utilitaires permettant de travailler automatiquement le code source (ajout de gestion d'erreur, commentaires, etc.) et une de mes fonctions permet de lister les modules et leurs procédures sans avoir à se soucier si une fonction contient le mot SUB ou FUNCTION ou PROPERTY.
Code:

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 ' ' Retourne le nom des modules et de leurs procédures d'un projet VB ' @return Dictionary le dictionnaire contenant les modules et leurs procédures ' Public Function DevRetournerModules() As Dictionary Dim oMod As VBIDE.CodeModule Dim dMod As Dictionary Dim dProc As Dictionary Dim v As Variant Dim i As Long Dim lTypeproc As VBIDE.vbext_ProcKind Dim sNomProc As String Set dMod = New Dictionary For Each v In Application.VBE.VBProjects(1).VBComponents Set oMod = Application.VBE.VBProjects(1).VBComponents(v.Name).CodeModule Set dProc = New Dictionary With oMod i = .CountOfDeclarationLines + 1 Do Until i >= .CountOfLines sNomProc = .ProcOfLine(i, lTypeproc) dProc.add i, sNomProc i = i + .ProcCountLines(sNomProc, lTypeproc) Loop End With dMod.add v.Name, dProc Next Set DevRetournerModules = dMod Set oMod = Nothing Set dMod = Nothing Set dProc = Nothing End Function
La fonction retourne un dictionnaire où chaque clé correspond à un module et chaque valeur est un autre dictionnaire contenant la combinaison noligne / nom proc. Peut être que cela va vous aider :)