Discussion :

[Nono02P]

Bonjour,

Ayant besoin de connaitre la liste des interfaces implémentées par un module de classe, je viens d'écrire une petite fonction qui va récupérer le tout et renvoi ça sous forme d'un dictionnary :

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
'A pour but de récupérer un dictionnaire comportant la liste des interfaces implémentées (en recherchant le mot clef Implements) pour un module de classe
    '@Param objClassModule : Module de classe appelant (Ecrire Me dans le module de classe)
    '@Param objVBProject : Projet VB (par défaut prend celui du projet actif)
    'Resultat : Retourne un objet Dictionnary qui contient la liste des interfaces implémentées par le module de classe
'Necessite les références :
    'Microsoft Visual Basic for Applications Extensibility 5.3
    'Microsoft Scripting Runtime
Public Function ModuleImplemente(ByVal objClassModule As Object, Optional ByVal objVBProject As VBProject) As Scripting.Dictionary
    Dim objVBComponent As VBComponent
    Dim objCodeModule As CodeModule
    Dim objDictionnary As Scripting.Dictionary
 
    Dim strLine As String
    Dim strInterfaceName As String
 
    Dim i As Long
    Dim lngCharPosition(2) As Long
 
    Set objDictionnary = New Scripting.Dictionary
 
    If objVBProject Is Nothing Then
        Set objVBProject = Application.VBE.ActiveVBProject
    End If
 
    For Each objVBComponent In objVBProject.VBComponents 'Boucle pour chaque Composant du projet VB (Sheets, ThisWorkbook, Userforms, Modules, Modules de classe)
        If objVBComponent.Name = TypeName(objClassModule) Then
            Set objCodeModule = objVBComponent.CodeModule 'Permet d'accéder au code contenu dans le composant du projet VB
            With objCodeModule
                i = 0
                For i = 1 To .CountOfDeclarationLines
                    strLine = .Lines(i, 1)
                    lngCharPosition(0) = InStr(1, strLine, "Implements", vbTextCompare)
                    If lngCharPosition(0) > 0 Then              'Si le mot "Implements" est trouvé dans la ligne
                        lngCharPosition(1) = InStr(1, Left(strLine, lngCharPosition(0)), "'", vbBinaryCompare)
                        If lngCharPosition(1) = 0 Then          'Si la ligne n'est pas passée en commentaire
                            lngCharPosition(2) = InStr(lngCharPosition(0) + Len("Implements "), strLine, " ", vbBinaryCompare)
                            If lngCharPosition(2) <> 0 Then     'Si un espace est écrit derrière le nom d'interface
                                strInterfaceName = Mid(strLine, lngCharPosition(0) + Len("Implements "), lngCharPosition(2) - lngCharPosition(0) - Len("Implements "))
                            Else
                                strInterfaceName = Right(strLine, Len(strLine) - lngCharPosition(0) - Len("Implements"))
                            End If
                            objDictionnary.Add strInterfaceName, strInterfaceName   'Ajoute l'interface dans le dictionnaire
                        End If
                    End If
                Next
                Set ModuleImplemente = objDictionnary
                Exit For
            End With
        End If
    Next objVBComponent
End Function

Pour l'utiliser, il suffit de l'appeler à partir de votre module de classe en écrivant par exemple :

Code :

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

1
2
Dim objDicInterfaces As Scripting.Dictionary
Set objDicInterfaces = ModuleImplemente(Me, Application.VBE.ActiveVBProject)

[Edit 06/08/18 à 18h25] : J'avais oublié, il faut activer des références (Dans Outils --> Références.) :
- Microsoft Scripting Runtime (pour jouer avec l'objet Dictionnary)
- Microsoft Visual Basic for Applications Extensibility. (pour pouvoir se balader dans le code du module et en récupérer des lignes)

Ensuite il faut cocher une case dans :
Options Excel --> Trust Center --> Macro Settings --> Developer Macro Settings
Vous devriez aussi cocher la case "Trust access to the VBA project object model"

Ou dans la version Française
Options Excel --> Centre de gestion de la confidentialité --> Paramètres du Centre de gestion de la confidentialité --> Paramètres des macros --> Paramètres de macros pour les développeurs.
Cocher Accès approuvé au modèle d'objet du projet VBA.

[Nono02P]

Bonjour,

Suite aux discutions avec Qwazerty sur ce lien

Voilà la fonction qui intègre les énumérations et les implémentations !

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
'A pour but d'analyser le code et de retourner un dictionnaire qui contient
'le contenu du code à analyser (en fonction des paramètres de recherche)
    '@Param lngRegExpParameter : permet de sélectionner le type d'analyse à faire
    '@Param blnOnlyDeclarationLines : Mettre à True pour analyser uniquement les lignes de code en déclaration seules
    '@Param strProjectName : Nom du Projet (si inconnu, celui-ci cherchera dans tous les projets)
    'Resultat : Retourne un objet Dictionnary qui contient :
        '- eImplements : Pour chaque Modules, contient la liste des interfaces implémentées par le module
        '- eEnumMembers : Pour chaque énumération, contient la liste des membres de l'énumération
Public Function AnalyserCode(lngRegExpParameter As gv_enumRegExp, Optional ByVal blnOnlyDeclarationLines As Boolean, Optional ByVal strProjectName As String) As Scripting.Dictionary
    Dim objVBProject As VBProject
    Dim objVBComponent As VBComponent
    Dim objCodeModule As CodeModule
    Dim dicResultat As Scripting.Dictionary
    Dim objRegExpEnum As RegExp
    Dim objColMatches As MatchCollection
    Dim objMatch As Match
    Dim strMatchExtraction As String
    Dim strVBProjectFileName As String
    Dim strCodeModule As String
    Dim vntSplittedProjectName As Variant
 
    Dim dicEnumerations As Scripting.Dictionary
    Dim dicEnumMembers As Scripting.Dictionary
    Dim objMatchesEnumMembers As MatchCollection
    Dim strListEnumMembers As String
    Dim lngEnumMemberValue As Long
    Dim vntLigneEnum As Variant
    Dim vntCoupleKV As Variant
 
    Dim dicModuleImplements As Scripting.Dictionary
    Dim dicInterface As Scripting.Dictionary
 
    Select Case lngRegExpParameter
        Case eEnumMembers
            Set dicEnumerations = New Scripting.Dictionary
            Set dicResultat = dicEnumerations
 
        Case eImplements
            Set dicModuleImplements = New Scripting.Dictionary
            Set dicResultat = dicModuleImplements
 
    End Select
 
    Set objRegExpEnum = New RegExp  'On instancie la RegExp
    With objRegExpEnum              'On parametre RegExp
        .Global = True
        .MultiLine = False
        .IgnoreCase = True
    End With
 
    If strProjectName <> vbNullString Then
        vntSplittedProjectName = Split(strProjectName, ".")
        strProjectName = vntSplittedProjectName(0)
    End If
 
    For Each objVBProject In Application.VBE.VBProjects
        If strProjectName <> vbNullString Then
            vntSplittedProjectName = Split(objVBProject.Filename, "\")    'Découpe le chemin d'accès du FileName avec le séparateur "\"
            vntSplittedProjectName = Split(vntSplittedProjectName(UBound(vntSplittedProjectName)), ".") 'Récupère le nom de fichier en retirant l'extension
            strVBProjectFileName = vntSplittedProjectName(0)  'Ecrit le nom de fichier dans la variable pour comparaison avec celui demandé
        End If
        If strVBProjectFileName = strProjectName Or strProjectName = vbNullString Then    'Si le projet demandé est le même que celui scruté ou si aucun projet n'est spécifié en paramètre
            For Each objVBComponent In objVBProject.VBComponents 'Boucle pour chaque Composant du projet VB (Sheets, ThisWorkbook, Userforms, Modules, Modules de classe)
                Set objCodeModule = objVBComponent.CodeModule 'Permet d'accéder au code contenu dans le composant du projet VB
                With objCodeModule
                    If blnOnlyDeclarationLines Then 'Limite le code du module à examiner aux lignes de déclaration ou à la totalité
                        strCodeModule = .Lines(1, .CountOfDeclarationLines)
                    Else
                        strCodeModule = .Lines(1, .CountOfLines)
                    End If
                    'On supprime les commentaires si ils sont trouvés
                    If RegExpExecute(objRegExpEnum, strCodeModule, "((\t| )*REM|')(\s*(.*)(\n(\t| )*?.*( _\n\s*.*))?)", objColMatches) Then
                        strCodeModule = objRegExpEnum.Replace(strCodeModule, Chr(13))
                    End If
 
                    Select Case lngRegExpParameter
                        Case eEnumMembers
                            'On recherche et exécute RegExp pour retrouver notre Enum
                            If RegExpExecute(objRegExpEnum, strCodeModule, "(\t| )*(Public |Private ).?Enum ((\w)*)", objColMatches) Then
                                'On prend en compte la liste des enum
                                For Each objMatch In objColMatches
                                    strMatchExtraction = objMatch.SubMatches(2)
                                    If RegExpExecute(objRegExpEnum, strCodeModule, "(\t| )*(Public |Private )?Enum " & strMatchExtraction & "((.|\n)*?)End Enum", objMatchesEnumMembers) Then
                                        'Logiquement un seul ou pas de résultat
                                        'On prend en compte la liste des enum
                                        'On supprime les tabulations, espaces, chr(10) éventuel(les)
                                        strListEnumMembers = Replace(Replace(Replace(objMatchesEnumMembers(0).SubMatches(2), Chr(9), vbNullString), " ", vbNullString), Chr(10), "")
                                        'Initialisation
                                        lngEnumMemberValue = -1
                                        Set dicEnumMembers = New Scripting.Dictionary
                                        'On boucle sur chaque ligne (membre d'énumération)
                                        For Each vntLigneEnum In Split(strListEnumMembers, Chr(13))
                                            If vntLigneEnum <> "" Then
                                               'On découpe pour trouver le couple key / valeur
                                               vntCoupleKV = Split(vntLigneEnum, "=")
 
                                               If UBound(vntCoupleKV) > 0 Then
                                                   'On retire les " et converti en Long (en cas de valeur Hexadécimale)
                                                   vntCoupleKV(1) = Replace(vntCoupleKV(1), """", vbNullString)
                                                   lngEnumMemberValue = CLng(vntCoupleKV(1))
                                               Else
                                                   'On détermine la valeur attribuée par VB
                                                   lngEnumMemberValue = lngEnumMemberValue + 1
                                               End If
                                               'On note le couple dans le dico
                                               If dicEnumMembers.Exists(lngEnumMemberValue) Then
                                                   dicEnumMembers.Item(lngEnumMemberValue) = dicEnumMembers.Item(lngEnumMemberValue) & "," & vntCoupleKV(0) 'Replace(dicEnumMembers.Item(lngEnumMemberValue), " ou", ",") & " ou " & vntCoupleKV(0)
                                               Else
                                                   dicEnumMembers.Add lngEnumMemberValue, vntCoupleKV(0)
                                               End If
                                            End If
                                        Next
                                        dicEnumerations.Add strMatchExtraction, dicEnumMembers
                                    End If
                                Next
                            End If
 
                        Case eImplements
                            'On recherche et exécute RegExp pour retrouver nos Implements
                            If RegExpExecute(objRegExpEnum, strCodeModule, "(\s)(Implements).((\w)*)", objColMatches) Then
                                Set dicInterface = New Scripting.Dictionary
                                'On prend en compte la liste des Implementations
                                For Each objMatch In objColMatches
                                    strMatchExtraction = objMatch.SubMatches(2)
                                    dicInterface.Add strMatchExtraction, strMatchExtraction
                                Next
                                dicModuleImplements.Add objVBComponent.Name, dicInterface
                            End If
 
                    End Select
                End With
            Next
        End If
    Next
 
    Set AnalyserCode = dicResultat
End Function
 
 
'Permet de tester et exécuter un RegExp (Expression Régulière)
    '@Param objRegExp : Instance de RegExp à exécuter
    '@Param strText : Texte à tester
    '@Param strPattern : Pattern à utiliser
    '@Param objMatches : MatchsCollection (résultats de la requête RegExp)
Public Function RegExpExecute(ByRef objRegExp As RegExp, ByVal strText As String, ByVal strPattern As String, ByRef objMatches As MatchCollection) As Boolean
    With objRegExp
        .Pattern = strPattern
        If .test(strText) Then
            Set objMatches = .Execute(strText)    'On lance la requête
            RegExpExecute = Not objMatches Is Nothing
        End If
    End With
End Function

Dans le module qui sert à déclarer les variables globales :

Code :

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

1
2
3
4
Public Enum gv_enumRegExp
    eImplements = 1
    eEnumMembers = 2
End Enum

J'ai modifié le tout afin d'avoir un Dictionnary renvoyant une liste de dictionnary qui eux contiennent les données.

ça permet entre autre de récupérer toutes les énumérations et pour chaque énumération récupérer les membres.
ça permet aussi de récupérer tous les modules de classe implémentant une interface et pour chacun d'entre eux les interfaces qu'ils implémentent.