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 |
Partager