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

**Jean-Philippe André** · 09/01/2009, 17h50

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 :

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

**Jean-Philippe André** · 12/01/2009, 09h49

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

**Tofalu** · 12/01/2009, 17h43

Envoyé par Tofalu

Salut,

On ne pourrais pas éviter :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

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

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.

**fold85** · 15/01/2009, 15h19

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

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

Contribuez

Discussions similaires

Partager

Partager