Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

  1. #1
    Rédacteur/Modérateur

    Lister les fonctions et procédures d'une base Access
    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
    Cycle de vie d'un bon programme :
    1/ ca fonctionne 2/ ca s'optimise 3/ ca se refactorise

    Pas de question technique par MP, je ne réponds pas

    Apprendre à programmer avec Access 2016 et Access 2019

    Pensez à consulter la FAQ Excel et la FAQ Access

    Derniers tutos
    Excel et les paramètres régionaux
    Les fichiers Excel binaires : xlsb,

    Autres tutos

  2. #2
    Rédacteur/Modérateur

    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
    Cycle de vie d'un bon programme :
    1/ ca fonctionne 2/ ca s'optimise 3/ ca se refactorise

    Pas de question technique par MP, je ne réponds pas

    Apprendre à programmer avec Access 2016 et Access 2019

    Pensez à consulter la FAQ Excel et la FAQ Access

    Derniers tutos
    Excel et les paramètres régionaux
    Les fichiers Excel binaires : xlsb,

    Autres tutos

  3. #3
    Expert éminent sénior
    Citation 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

  4. #4
    Rédacteur/Modérateur

    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.
    Cycle de vie d'un bon programme :
    1/ ca fonctionne 2/ ca s'optimise 3/ ca se refactorise

    Pas de question technique par MP, je ne réponds pas

    Apprendre à programmer avec Access 2016 et Access 2019

    Pensez à consulter la FAQ Excel et la FAQ Access

    Derniers tutos
    Excel et les paramètres régionaux
    Les fichiers Excel binaires : xlsb,

    Autres tutos

  5. #5
    Membre à l'essai
    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

###raw>template_hook.ano_emploi###