IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
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
    Membre régulier
    Homme Profil pro
    Automaticien
    Inscrit en
    décembre 2015
    Messages
    84
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Pas de Calais (Nord Pas de Calais)

    Informations professionnelles :
    Activité : Automaticien

    Informations forums :
    Inscription : décembre 2015
    Messages : 84
    Points : 107
    Points
    107
    Par défaut [Outil-E] Récupérer les interfaces implémentées par un Module de classe
    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.
    Il y a 10 types de personnes dans le monde : ceux qui comptent en binaire et les autres.

  2. #2
    Membre régulier
    Homme Profil pro
    Automaticien
    Inscrit en
    décembre 2015
    Messages
    84
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Pas de Calais (Nord Pas de Calais)

    Informations professionnelles :
    Activité : Automaticien

    Informations forums :
    Inscription : décembre 2015
    Messages : 84
    Points : 107
    Points
    107
    Par défaut
    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.
    Il y a 10 types de personnes dans le monde : ceux qui comptent en binaire et les autres.

Discussions similaires

  1. Connaitre les interfaces implémentées par un objet
    Par Nono02P dans le forum Général VBA
    Réponses: 5
    Dernier message: 06/08/2018, 18h03
  2. Récupérer une interface implémentée par une classe
    Par samaury dans le forum Langage
    Réponses: 2
    Dernier message: 20/04/2010, 22h04
  3. Réponses: 1
    Dernier message: 02/03/2007, 10h37
  4. Réponses: 1
    Dernier message: 09/02/2007, 09h50
  5. [Access] Récupérer les champs commençant par ...
    Par paflolo dans le forum Langage SQL
    Réponses: 3
    Dernier message: 15/02/2006, 10h35

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo