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

**JMP62** · 22/10/2024, 23h30

Bonjour à tous

En m'inspirant de différents posts, j'ai complété en mettant aussi les commentaires qui suivent le titre de la procedure
Soit pour la base actuelle : Public Function Liste_Procedures_Fonctions_VBA_ThisDatabase()
Soit pour une autre base : Public Function Liste_Procedures_Fonctions_VBA(pathbase As String) As Boolean

Le code est le suivant:

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
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
Option Compare Database
Option Explicit
 
'Source: https://www.developpez.net/forums/d670103/logiciels/microsoft-office/access/contribuez/lister-fonctions-procedures-d-base-access/
 
'Liste tous les Module, Sub et Function dans le projet en cours, dans la table T_Liste_Procedures
'La table peut etre crée avec la Sub CreateTable (voir ci-dessous)
'Pour exécuter: ? Liste_Procedures_Fonctions_VBA_ThisDatabase()
'ou mettre le curseur dans la procédure et Exécuter
'Les données de la table T_Liste_Procedures peuvent etre mises facilement dans Excel (copier coller)
 
Public Function Liste_Procedures_Fonctions_VBA_ThisDatabase() As Boolean
    Dim i As Integer, k As Integer
    Dim cible As String, prmModule As String, prmComment As String
    Dim prmType As String, prmName As String, prmParam As String, prmReturn As String, prmPath As String, prmScope As String
    'On Error GoTo fin
 
    DoCmd.RunSQL "delete from T_LISTE_PROCEDURES"
    For i = 1 To VBE.ActiveVBProject.VBComponents.Count
        With VBE.ActiveVBProject.VBComponents.Item(i).CodeModule
            prmModule = VBE.ActiveVBProject.VBComponents.Item(i).CodeModule
            For k = 1 To .CountOfLines
                cible = .Lines(k, 1)
                If Left(cible, 1) <> "'" Then
                    If InStr(1, cible, "Function ") > 0 And InStr(1, cible, "Function ") < 15 Then 'le 10 évite les cibles parasites Function
                        prmComment = RecupComment(cible)
                        prmType = "Function"
                        prmName = Trim(RecupererTexteEntreBornes(cible, "Function", "("))
                        prmParam = RecupererTexteEntreBornes(cible, "(", ")")
                        prmReturn = RecupererTexteEntreBornes(cible, ") As", "")
                        prmScope = IIf(InStr(1, cible, "Private") <> 0, "Private", IIf(InStr(1, cible, "Public") <> 0, "Public", ""))
                        CurrentDb.Execute "INSERT INTO T_LISTE_PROCEDURES (path,module,scope,comment,category,procname,param,return)" _
                            & "VALUES ('" & "CurrentProject" & "','" & prmModule & "','" & prmScope & "','" & prmComment & "','" & prmType & "','" & prmName & "' ,'" & prmParam & "','" & prmReturn & "');"
                    End If
                    If InStr(1, cible, "Sub ") > 0 And InStr(1, cible, "Sub ") < 15 Then ''le 10 évite les cibles parasites Sub
                        prmComment = RecupComment(cible)
                        prmType = "Sub"
                        prmName = Trim(RecupererTexteEntreBornes(cible, prmType, "("))
                        prmParam = RecupererTexteEntreBornes(cible, "(", ")")
                        prmScope = IIf(InStr(1, cible, "Private") <> 0, "Private", IIf(InStr(1, cible, "Public") <> 0, "Public", ""))
                        CurrentDb.Execute "INSERT INTO T_LISTE_PROCEDURES (PATH,module,scope,comment,category,procname,param) " _
                            & "VALUES ('" & "CurrentProject" & "','" & prmModule & "','" & prmScope & "','" & prmComment & "','" & prmType & "','" & prmName & "','" & prmParam & "')"
                    End If
                    prmParam = ""
                End If
            Next k
        End With
    Next i
    'CurrentDb.Execute "UPDATE T_LISTE_PROCEDURES SET PARAM = '' WHERE Left(PARAM,1)=')'"
    Liste_Procedures_Fonctions_VBA_ThisDatabase = True
Exit Function
fin:
    Liste_Procedures_Fonctions_VBA_ThisDatabase = False
    Resume Next
End Function
 
'Utilise table T_LISTE_PROCEDURES
'? Liste_Procedures_Fonctions_VBA("D:\_AccessMoi\Harmonie173.accdb")
 
Public Function Liste_Procedures_Fonctions_VBA(pathbase As String) As Boolean 'comment
    Dim strSQL As String
    Dim Accmodule As module
    Dim i As Integer, k As Integer
    Dim oDb As Database, oAccess As New Access.Application
    Dim cible As String, prmModule As String, prmComment As String
    Dim prmType As String, prmName As String, prmParam As String, prmReturn As String, prmPath As String, prmScope As String
    'On Error GoTo fin
 
    DoCmd.RunSQL "delete from T_LISTE_PROCEDURES"
 
    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
            prmModule = oAccess.VBE.VBProjects(1).VBComponents.Item(i).CodeModule
            For k = 1 To .CountOfLines
                cible = .Lines(k, 1)
                If Left(cible, 1) <> "'" Then
                    If InStr(1, cible, "Function ") > 0 And InStr(1, cible, "Function ") < 15 Then 'le 10 évite la cible "   Currentdb.execute etc...
                        prmComment = RecupComment(cible)
                        prmType = "Function"
                        prmName = Trim(RecupererTexteEntreBornes(cible, "Function", "("))
                        prmParam = RecupererTexteEntreBornes(cible, "(", ")")
                        prmReturn = RecupererTexteEntreBornes(cible, ") As", "")
                        prmScope = IIf(InStr(1, cible, "Private") <> 0, "Private", IIf(InStr(1, cible, "Public") <> 0, "Public", ""))
                        CurrentDb.Execute "INSERT INTO T_LISTE_PROCEDURES (PATH,module,scope,comment,category,procname,param,return)" _
                            & "VALUES ('" & pathbase & "','" & prmModule & "','" & prmScope & "','" & prmComment & "','" & prmType & "','" & prmName & "','" & prmParam & "','" & prmReturn & "');"
                    End If
                    If InStr(1, cible, "Sub ") > 0 And InStr(1, cible, "Sub ") < 15 Then 'le 10 évite la cible "   Currentdb.execute etc...
                        prmComment = RecupComment(cible)
                        prmType = "Sub"
                        prmName = Trim(RecupererTexteEntreBornes(cible, "Sub", "("))
                        prmParam = RecupererTexteEntreBornes(cible, "(", ")")
                        prmScope = IIf(InStr(1, cible, "Private") <> 0, "Private", IIf(InStr(1, cible, "Public") <> 0, "Public", ""))
                        CurrentDb.Execute "INSERT INTO T_LISTE_PROCEDURES (PATH,module,scope,comment,category,procname,param)" _
                            & "VALUES ('" & pathbase & "','" & prmModule & "','" & prmScope & "','" & prmComment & "','" & prmType & "','" & prmName & "','" & prmParam & "');"
                    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
 
Public Function RecupererTexteEntreBornes(texte As String, textedebut As String, textefin As String) As String
    Dim result As String, debut As Integer, fin As Integer, v As Variant
    v = Split(texte, "'")
    If UBound(v) > 0 Then texte = v(0) 'pour éliminer la partie commentaire
    debut = InStr(1, texte, textedebut)
    fin = InStr(debut + Len(textedebut), texte, textefin)
    If debut > 0 Then
        If textedebut = "Function" Or textedebut = "Sub" Then result = Mid(texte, debut + Len(textedebut) + 1, fin - debut - Len(textedebut) - 1) 'name
        If textedebut = "(" Then result = Mid(texte, debut + 1, fin - debut - 1)   'param
        If textedebut = ") as" Then result = Mid(texte, fin + 1, Len(texte) - fin) 'return
    End If
    RecupererTexteEntreBornes = result
End Function
 
Public Function RecupComment(cible As String) As String
    Dim v, i As Integer, txt As String
    v = Split(cible, "'")
    If UBound(v) >= 1 Then 'un commentaire existe après Function ou Sub
        v(0) = "" 'enlever le texte avant '
        txt = Join(v, " ") 'reconstituer le commentaire, mais remplacer ' par Espace pour éviter l'erreur avec CurrentDb.Execute "INSERT INTO ...
        RecupComment = Right(txt, Len(txt) - 1) 'pour enlever le caractère du début
    End If
End Function
 
'https://learn.microsoft.com/en-us/office/client-developer/access/desktop-database-reference/create-table-statement-microsoft-access-sql
 
Public Sub CreateTable() 'crée table' T_Liste_Procedures
    CurrentDb.Execute "CREATE TABLE T_Liste_Procedures " _
        & "(Path MEMO, Module CHAR, Scope CHAR, Category MEMO,Nom MEMO, Param MEMO, Return MEMO, Commentaire MEMO);"
    RefreshDatabaseWindow
    'les données de la table peuvent etre exportées dans un fichier Excel
End Sub
 
Public Sub Test_RecupererTexteEntreBornes()
    Dim cible As String
    cible = "Private Function Liste_Procedures_Fonctions_VBA_ThisDatabase(param) as Boolean"
    Debug.Print "name", RecupererTexteEntreBornes(cible, "Function", "(")
    Debug.Print "param", RecupererTexteEntreBornes(cible, "(", ")")
    Debug.Print "return", RecupererTexteEntreBornes(cible, ") as", "")
End Sub

Par contre je ne sais pas comment clore la discussion
Bonne journée

**JMP62** · 23/10/2024, 00h11

La procedure de creation de table doit etre modifiée ainsi;

Code :

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

1
2
3
4
5
Public Sub CreateTable() 'crée table' T_Liste_Procedures
    CurrentDb.Execute "CREATE TABLE T_Liste_Procedures " _
        & "(Path MEMO, Module CHAR, Scope CHAR, Category MEMO, ProcName MEMO, Param MEMO, Return MEMO, Comment MEMO);"
    RefreshDatabaseWindow
End Sub

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

Contribuez

Discussions similaires

Partager

Partager