Classe vb tableaux multi dimentionnels redilmentionables sur toutes les dimensions

Commenter

Contenu du snippet

Ce module de classe implémente un tableau multidimentionnel sans limite, permettant de redimentionner n'importe quelle sous ensemble de dimension.
Classe : multitbl
Permet de faire ce que ne permet pas Redim Preserve

MaTable.int 5,3,12 -> dimentionne un tableau vierge 5 X 3 X 12 Elements
MaTable.Redefine 7 X 2 X 5 -> redéfini l'ancien tableau en conservant les anciens éléments

Juste faire copier coller du source dans un nouveau module de classe

Propriétés:

NbDim -> Renvoie le nombre de dimensions
UBounds -> renvoie un tableau contenant le nombre d'éléments de chaque dimension
DimUbouns(Index) -> Renvoie le nb d'éléments de la dimension Index
Item (Index1,Index2, ... ,Indexn) -> Propriété en lecture - écriture d'accès à l'élément du tableau

Méthodes:

Init (Nb1, Nb2, ..., Nbn) -> défini un tableaux de n dimensions
Redefine (Nb1, Nb2, ... Nbn) -> redéfini le nombre d'éléments des n dimensions (on ne peut pas changer le nombre de dimensions)

Source / Exemple : 


Option Explicit
'====================================================================
'=              MultiTBL
'=              Créé par T Bertrand - TbeSoft - 2004
'====================================================================
'
'
'   Classe MultiTbl: Tableau à n dimensions redimentionables
'
'   Propriétés:
'
'       Lecture seule:
'           NbDim: renvoie le nombre de dimensions
'           UBounds: Renvoie un tableau contenant la taille de chaque dimension
'           DimUBound(Index): renvoie la taille de la dimension Index
'       Lecture - Ecriture
'           Item (Idx1, Idx2, ... Idxn) : Accède à l'élément de tableau
'
'       Methodes
'           Init Nb1, Nb2, ... Nbn : Initialise un tableau de dimension n
'           Redefine Nb1,Nb2, ... , NbN: Redefini le tableau en modifiant les tailles
'                                                        et en conservant les anciennes valeurs
'
'
Private LtblList As Collection
Private LDim As Integer
Private LDimensions() As Long

Public Property Get NbDim() As Integer
    NbDim = LDim
End Property

Public Property Get DimUBound(Index As Integer) As Long
Dim tbl() As Long
Dim I As Long
Dim lst As Long
Dim One(1) As Long

    For I = 1 To LDim
        ReDim Preserve tbl(I)
        tbl(I) = LstDim(I, LtblList)
    Next I
    DimUBound = tbl(Index)
End Property

Public Property Get Item(ParamArray Index()) As Variant
Dim I As Long
Dim LLst As Collection
    
    Set LLst = LtblList
    For I = 1 To LDim - 2
        Set LLst = LLst(Index(I - 1))
    Next I
    Item = LLst(Index(LDim - 2))(Index(LDim - 1))
End Property

Public Property Let Item(ParamArray Index(), Valeur As Variant)
Dim I As Long
Dim LLst As Collection
Dim tbl() As Variant
    
    Set LLst = LtblList
    For I = 1 To LDim - 2
        Set LLst = LLst(Index(I - 1))
    Next I
    tbl = LLst(Index(LDim - 2))
    tbl(Index(LDim - 1)) = Valeur
    LLst.Remove Index(LDim - 2)
    If Index(LDim - 2) > LLst.Count Then
        LLst.Add tbl
    Else
        LLst.Add tbl, , Index(LDim - 2)
    End If
End Property

Public Property Get UBounds() As Long()
Dim tbl() As Long
Dim I As Long
Dim lst As Long

    For I = 1 To LDim
        ReDim Preserve tbl(I)
        tbl(I) = LstDim(I, LtblList)
    Next I
    UBounds = tbl
End Property

Private Function LstDim(ByVal Rang As Integer, lst As Collection) As Long
Dim LLst As New Collection
Dim I As Long

    Set LLst = lst
    For I = 1 To Rang - 1
        If I < LDim - 1 Then
            Set LLst = LLst(1)
        End If
    Next I
    If Rang = LDim Then
        LstDim = UBound(LLst(1))
    Else
        LstDim = LLst.Count
    End If
End Function

Public Sub Init(ParamArray Dimensions())
Dim I As Long
Dim J As Long
Dim lst As Collection

    I = Dimensions(0)
    ReDim LDimensions(UBound(Dimensions))
    For J = 0 To UBound(Dimensions)
        LDimensions(J) = Dimensions(J)
    Next J
    Set LtblList = New Collection
    For J = 1 To I
        AjouteDim LtblList, 1
    Next J
    LDim = UBound(Dimensions) + 1
End Sub

Public Sub Redefine(ParamArray Dimensions())
Dim I As Long
Dim J As Long
Dim lst As Collection
Dim OldDim() As Long
Dim newList As Collection

    If UBound(Dimensions) <> LDim - 1 Then
        Exit Sub
    End If
    I = Dimensions(0)
    ReDim OldDim(LDim - 1)
    For J = 0 To UBound(Dimensions)
        OldDim(J) = LDimensions(J)
        LDimensions(J) = Dimensions(J)
    Next J
    Set newList = New Collection
    For J = 1 To I
        If J <= LtblList.Count Then
            Affecte LtblList(J), newList, 1
        Else
            AjouteDim newList, 1
        End If
    Next J
    Set LtblList = newList
End Sub

Private Sub Affecte(L1 As Collection, L2 As Collection, Rang As Long)
Dim I As Long
Dim J As Long
Dim K As Long
Dim LLst As Collection
Dim tbl() As Variant

    I = LDimensions(UBound(LDimensions))
    J = LDimensions(Rang)
    If Rang = UBound(LDimensions) Then
        ReDim tbl(I)
        If L1.Count >= L2.Count + 1 Then
            For K = 1 To I
                If K <= UBound(L1(L2.Count + 1)) Then tbl(K) = L1(L2.Count + 1)(K)
            Next K
        End If
        L2.Add tbl
    Else
        Set LLst = New Collection
        For K = 1 To J
            If K <= L1.Count Then
                If Rang < LDim - 2 Then
                    Affecte L1(K), LLst, Rang + 1
                Else
                    Affecte L1, LLst, Rang + 1
                End If
            Else
                AjouteDim LLst, Rang + 1
            End If
        Next K
        L2.Add LLst
    End If
End Sub

Private Sub AjouteDim(L2 As Collection, ByVal Rang As Long)
Dim I As Long
Dim J As Long
Dim K As Long
Dim LLst As Collection
Dim tbl() As Variant

    I = LDimensions(UBound(LDimensions))
    J = LDimensions(Rang)
    If Rang = UBound(LDimensions) Then
        ReDim tbl(I)
        L2.Add tbl
    Else
        Set LLst = New Collection
        For K = 1 To J
            AjouteDim LLst, Rang + 1
        Next K
        L2.Add LLst
    End If
End Sub

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (fregoli)