Grid entièrement codée et personnalisée avec possibilité de vscrollbar et couleur

Soyez le premier à donner votre avis sur cette source.

Vue 9 108 fois - Téléchargée 2 593 fois

Description

Il s'agit d'une grid entièrement personnalisée, avec un VScrollBar qui apparaît lorsque le nombre de lignes dépassent la limite que vous avez fixé. Vous pouvez mettre des conditions pour colorer les cellules. Ce code possède 2 types de grid, l'une avec sélecteur et l'autre sans.

Source / Exemple :


Option Explicit
Private Tbl() As Variant 'Création d'un tableau à vide en vue d'un dimensionnement dynamique
'Dessine le tableau à partir de la requête sql
Public Sub DesignTable(ByVal cn As ADODB.Connection, ByVal rs As ADODB.Recordset, sql As String, sCpt As Integer, Frm As Form, ParamArray var() As Variant)
    Dim i, j, k, cpt, PosX, PosY, Col, Lig, tmp As Integer
    rs.Open sql, cn, 1, 2
    'sCpt Définition du nombre de lignes à partir desquelles le scroll va commencer à opérer
    Col = rs.Fields.Count 'Nb de colonnes
    Lig = rs.RecordCount  'Nb de lignes
    tmp = 0
    'Définition du tableau récupérant les valeurs passées par la table
    ReDim Tbl(Col - 1, Lig - 1) As Variant 'Chargement des dimensions réelles du tableau
    PosX = Frm.Cell(0).Left 'Récupération de la position initiale
    PosY = Frm.Cell(0).Top  'de la cellule en haut à gauche
    If var(0) <> 0 Then
        Frm.Cell(0).Width = var(0) 'défini la taille des cellule
        Frm.Titre(0).Width = var(0)
    End If
    For i = 0 To UBound(var)
        tmp = tmp + var(i) 'Longueur d'une ligne
    Next i
    'Définition de la taille du cadre qui entoure les cellules.
    Frm.Cadre.Height = ((Lig + 1) * Frm.Cell(0).Height) + 30 '+1 à cause des titres
    Frm.Cadre.Width = tmp + 30 'épaisseur
    'Rend visible, place et initialise les paramètre du VScroll
    If Lig > sCpt Then
        Frm.VScroll.Min = 1
        Frm.VScroll.Max = Lig - sCpt + 1 'Définition de la taille maximale du scroll
        Frm.VScroll.Visible = True
        Frm.Blanc.Visible = True
        Frm.VScroll.Left = Frm.Cell(0).Left + tmp
        Frm.VScroll.Height = sCpt * Frm.Cell(0).Height
        Frm.VScroll.Top = Frm.Cell(0).Top
        Frm.Blanc.Left = Frm.VScroll.Left
        Frm.Blanc.Top = Frm.Titre(0).Top
        'Définition de la taille du cadre qui entoure les cellules en fonction du scroll
        Frm.Cadre.Height = ((sCpt + 1) * Frm.Cell(0).Height) + 30
        Frm.Cadre.Width = tmp + Frm.VScroll.Width + 30   'Sélecteur + Vscrool  + épaisseur
    End If
    cpt = Col * Lig 'Nb de cellules totales
    k = 0
    'Création des titres des cellules
    For i = 0 To Col - 1
        If i > 0 Then
            Load Frm.Titre(i): Frm.Titre(i).Visible = True
            Frm.Titre(i).Text = rs.Fields(i).Name 'Récupération du nom des colonnes
            Frm.Titre(i).Width = var(i)
            Frm.Titre(i).Left = Frm.Titre(i - 1).Left + Frm.Titre(i - 1).Width
            Frm.Titre(i).Top = Frm.Titre(0).Top
        Else
            Frm.Titre(0).Text = rs.Fields(0).Name
        End If
    Next i
    'Remplissage du tableau de Variant
    j = 0
    While rs.EOF = False
        For i = 0 To (Col - 1)
            'Si une valeur est null alors on insert une chaine vide dans le tableau
            Tbl(i, j) = IIf(IsNull(rs.Fields(i)), vbNullChar, rs.Fields(i))
        Next i
        j = j + 1
        rs.MoveNext
    Wend
    rs.Close
    'Répartition des sélecteurs et des cellules
    'Exemple de tableau, les chiffres représentant les index.
    '---------------------
    '|T0 |T1 |T2 |T3 |T4 |
    '---------------------
    '| 0 | 1 | 2 | 3 | 4 |
    '---------------------
    '| 5 | 6 | 7 | 8 | 9 |
    '---------------------
    k = 0
    For j = 0 To (Lig - 1)
        For i = 0 To (Col - 1)
            'Calcul position des cellules leur affecte les valeurs
            If ((i = 0) And (j = 0)) Then
                Frm.Cell(k).Text = Tbl(i, j)
                Condcoul Frm, k, Col, Lig 'condition couleur
            Else
                If ((k) Mod (Col) = 0) Then 'Créé et place toutes les cellules qui sont du coté gauche
                    Frm.Cell(0).Width = var(0)
                    Load Frm.Cell(k)
                    If (j < (sCpt)) Then Frm.Cell(k).Visible = True
                    Frm.Cell(k).Top = Frm.Cell(k - 1).Top + Frm.Cell(k).Height 'le .top de la cellule précédente + la hauteur de la cellule
                    Frm.Cell(k).Left = Frm.Cell(0).Left
                    Frm.Cell(k).Text = Tbl(i, j)
                    Condcoul Frm, k, Col, Lig 'condition couleur
                Else
                    'Crée et place toutes les autres cellules
                    Frm.Cell(0).Width = var(i)
                    Load Frm.Cell(k)
                    If (j < (sCpt)) Then Frm.Cell(k).Visible = True
                    Frm.Cell(k).Top = Frm.Cell(k - 1).Top
                    If k = 1 Then
                        Frm.Cell(1).Left = Frm.Cell(0).Left + var(0)
                    Else
                        Frm.Cell(k).Left = Frm.Cell(k - 1).Left + Frm.Cell(k - 1).Width
                    End If
                    Frm.Cell(k).Text = Tbl(i, j)
                    Condcoul Frm, k, Col, Lig 'condition couleur
                End If
            End If
            k = k + 1
        Next i
    Next j
    Frm.Cell(0).Width = var(0)
End Sub
'Place et rend visible les cellules que l'on souhaite voir
Public Sub ReGetCell(Départ As Integer, Frm As Form, ByVal Col As Integer, ByVal Lig As Integer, sCpt As Integer)
    Dim k, i, j, PosX, PosY As Integer
    PosY = Frm.Titre(0).Top + Frm.Titre(0).Height
    PosX = Frm.Titre(0).Left
    k = Départ 'N° de la 1ere cellule en haut à gauche
    j = 0
    'Efface toutes les cellules
    For i = 0 To ((Col * Lig) - 1)
        Frm.Cell(i).Visible = False
    Next i
    'Ne fait apparaitre que les cellules nécessaires
    For i = Départ To ((Col * sCpt) + Départ - 1)
        Frm.Cell(i).Visible = True
    Next i
    While k < (Départ + (Col * sCpt)) 'Ne place que les cellules concernées
        If k = Départ Then 'Place en haut à gauche la cellule
            Frm.Cell(k).Top = PosY
            Frm.Cell(k).Left = PosX
            k = k + 1
        Else
            For i = 0 To Col - 1
                If k <> 1 Then
                    If k < ((Col * sCpt) + Départ) Then
                        If ((k) Mod (Col) = 0) Then 'Créé et place toutes les cellules qui sont du coté gauche
                            Frm.Cell(k).Top = Frm.Cell(k - 1).Top + Frm.Cell(k).Height 'le .top de la cellule précédente + la hauteur de la cellule
                            Frm.Cell(k).Left = Frm.Cell(Départ).Left
                        Else
                            'Crée et place toutes les autres cellules
                            Frm.Cell(k).Top = Frm.Cell(k - 1).Top
                            Frm.Cell(k).Left = Frm.Cell(k - 1).Left + Frm.Cell(k - 1).Width
                        End If
                    End If
                Else 'si k =1
                    If i > 0 Then
                        If ((k) Mod (Col) = 0) Then
                            Frm.Cell(k).Top = Frm.Cell(k - 1).Top + Frm.Cell(k).Height 'le .top de la cellule précédente + la hauteur de la cellule
                            Frm.Cell(k).Left = Frm.Cell(Départ).Left
                        Else
                            Frm.Cell(k).Top = Frm.Cell(k - 1).Top
                            Frm.Cell(k).Left = Frm.Cell(k - 1).Left + Frm.Cell(k - 1).Width
                        End If
                    End If
                End If
                If k <> 1 Then k = k + 1
                If ((k = 1) And (i <> 0)) Then k = k + 1
            Next i
            j = j + 1
        End If
    Wend
End Sub
'#####################################################################################################
'#     Dessine le tableau avec un sélecteur, attention, il ne faut passer une rq contenant un n°auto #
'#####################################################################################################
'Dessine le tableau à partir de la requête sql - NA = NuméroAuto
Public Sub DesignTableNA(ByVal cn As ADODB.Connection, ByVal rs As ADODB.Recordset, sql As String, sCpt As Integer, Frm As Form, ParamArray var() As Variant)
    Dim i, j, l, cpt, PosY, Col, Lig, tmp As Integer
    rs.Open sql, cn, 1, 2
    'sCpt Définition du nombre de lignes à partir desquelles le scroll va opérer
    Col = rs.Fields.Count
    Lig = rs.RecordCount
    tmp = 0
    'Définition du tableau récupérant les valeurs passées par la table
    ReDim Tbl(Col - 1, Lig - 1) As Variant 'Chargement des dimensions réelles du tableau
    PosY = Frm.Cell(0).Top  'de la cellule en haut à gauche
    If var(0) <> 0 Then
        Frm.Cell(0).Width = var(0) 'défini la taille des cellule
        Frm.Titre(1).Width = var(0)
    End If
    For l = 0 To UBound(var)
        tmp = tmp + var(l) 'Longueur d'une ligne
    Next l
    'Définition de la taille du cadre qui entoure les cellules.
    Frm.Cadre.Height = ((Lig + 1) * Frm.Cell(0).Height) + 30 '+1 à cause des titres
    Frm.Cadre.Width = tmp + Frm.Sélecteur(0).Width + 30 'Sélecteur + épaisseur => 375 + 30
    'Rend visible, place et initialise les paramètre du VScroll
    If Lig > sCpt Then
        Frm.VScroll.Min = 1
        Frm.VScroll.Max = Lig - sCpt + 1
        Frm.VScroll.Visible = True
        Frm.Blanc.Visible = True
        Frm.VScroll.Left = Frm.Cell(0).Left + tmp
        Frm.VScroll.Height = (sCpt) * Frm.Cell(0).Height
        Frm.VScroll.Top = Frm.Cell(0).Top
        Frm.Blanc.Left = Frm.VScroll.Left
        Frm.Blanc.Top = Frm.Titre(1).Top
        'Définition de la taille du cadre qui entoure les cellules en fonction du scroll
        Frm.Cadre.Height = ((sCpt + 1) * Frm.Cell(0).Height) + 30
        Frm.Cadre.Width = tmp + Frm.Sélecteur(0).Width + Frm.VScroll.Width + 30  'Sélecteur + Vscrool  + épaisseur
    End If
    cpt = Col * Lig 'Nb de cellules totales
    'Création des titres des cellules
    For i = 1 To Col - 1
        If i > 1 Then
            Load Frm.Titre(i): Frm.Titre(i).Visible = True
            Frm.Titre(i).Text = rs.Fields(i).Name
            Frm.Titre(i).Width = var(i - 1)
            Frm.Titre(i).Left = Frm.Titre(i - 1).Left + Frm.Titre(i - 1).Width
            Frm.Titre(i).Top = Frm.Titre(1).Top
            
        Else
            '1er Vide
            'On ne prend pas le titre du NuméroAuto c'est inutile
            Frm.Titre(1).Text = rs.Fields(1).Name
        End If
    Next i
    'Remplissage du tableau de Variant
    j = 0
    While rs.EOF = False
        For i = 0 To (Col - 1)
            'Si valeur null alors on insert une chaine vide dans le tableau
            Tbl(i, j) = IIf(IsNull(rs.Fields(i)), vbNullChar, rs.Fields(i))
        Next i
        j = j + 1
        rs.MoveNext
    Wend
    rs.Close
    'Répartition des sélecteurs et des cellules
    'Exemple de tableau, les chiffres représentant les index.
    '------------------------
    '|x |T1 |T2 |T3 |T4 |T5 |
    '------------------------
    '|0>| 1 | 2 | 3 | 4 | 5 |
    '------------------------
    '|1>| 6 | 7 | 8 | 9 |10 |
    '------------------------
    For j = 0 To (Lig - 1)   'j = 0 To (sCpt - 1)
        For i = 0 To (Col - 1)
            'Calcul position des cellules et des sélecteurs
            Select Case i
                Case 0 'Colonne du sélecteur
                    If (j = 0) Then '1er sélecteur
                        Frm.Sélecteur(0).Tag = Tbl(i, j) 'récupération de la clé primaire pr d'éventuelle manipulation
                    Else 'ligne suivante, on crée les autres sélecteur
                        Load Frm.Sélecteur(j)
                        If (j < (sCpt)) Then Frm.Sélecteur(j).Visible = True
                        Frm.Sélecteur(j).Tag = Tbl(0, j)
                        Frm.Sélecteur(j).Top = Frm.Sélecteur(0).Top + (Frm.Sélecteur(0).Height * j)
                    End If
                Case Else 'On rentre dans les colonnes des cellules i > 0
                    tmp = 0 'Change la taille de Cell(0) afin que les cellules créée à partir de cell(0)
                    Frm.Cell(0).Width = var(i - 1) 'prennent la taille de cette dernière
                    Load Frm.Cell(i + ((Col - 1) * j))
                    If (j < (sCpt)) Then Frm.Cell(i + ((Col - 1) * j)).Visible = True
                    Frm.Cell(i + ((Col - 1) * j)).Text = Tbl(i, j)
                    Frm.Cell(i + ((Col - 1) * j)).Top = Frm.Sélecteur(j).Top
                    Frm.Cell(1).Left = Frm.Cell(0).Left
                    If (((i + ((Col - 1) * j)) - ((Col - 1) * (j - 1))) Mod (Col)) = 0 Then
                        Frm.Cell(i + ((Col - 1) * j)).Left = Frm.Cell(0).Left 'Si ce sont les cellules du coté gauche
                    Else 'pour les autres cellules, la position se fait par rapport à la précédente
                        Frm.Cell(i + ((Col - 1) * j)).Left = Frm.Cell(i + ((Col - 1) * j) - 1).Left + Frm.Cell(i + ((Col - 1) * j) - 1).Width
                    End If
                    Condcoul Frm, (i + ((Col - 1) * j)), Col, Lig 'condition couleur
            End Select
        Next i
    Next j
End Sub
'########################################################################################################
'#            Place et rend visible les cellules que l'on souhaite voir en fonction du scroll           #
'########################################################################################################
Public Sub ReGetCellNA(Départ As Integer, Frm As Form, ByVal Col As Integer, ByVal Lig As Integer, sCpt As Integer)
    Dim k, i, j As Integer
    k = 0 'Compteur de ligne
    j = 0
    'Rend toutes les cellules et les sélecteurs invisibles
    For i = 0 To ((Col - 1) * Lig)
        Frm.Cell(i).Visible = False 'ion
    Next i
    For i = 0 To Lig - 1
        Frm.Sélecteur(i).Visible = False
    Next i
    'Ne fait apparaître que les cellules nécessaires
    For i = 1 + ((Départ - 1) * (Col - 1)) To (((Départ - 1) + sCpt) * (Col - 1))
        Frm.Cell(i).Visible = True
    Next i
    For i = (Départ - 1) To ((sCpt - 1) + (Départ - 1))
        Frm.Sélecteur(i).Visible = True
    Next i
    'Positionnement des cellules et des sélecteurs
    For j = (Départ - 1) To ((sCpt - 1) + (Départ - 1))
        For i = 0 To (Col - 1)
            'Calcul position des cellules et des sélecteurs
            Select Case i
                Case 0 'Colonne des sélecteurs
                    If (j = (Départ - 1)) Then '1er sélecteur en haut à gauche
                        Frm.Sélecteur(Départ - 1).Top = Frm.Cell(0).Top 'récupère la position de départ de cell(0) qui ne bouge pas et qui est invisible
                    Else 'ligne suivante, on crée les autres sélecteur
                        Frm.Sélecteur(j).Top = Frm.Sélecteur(Départ - 1).Top + (Frm.Sélecteur(Départ - 1).Height * k)
                    End If
                Case Else 'On rentre dans les colonnes des cellules i > 0
                    Frm.Cell(i + ((Col - 1) * j)).Top = Frm.Sélecteur(j).Top
                    'Frm.Cell(i + ((Col - 1) * j)).Left = Frm.Cell(0).Left + (Frm.Cell(0).Width * (i - 1))
                    If (((i + ((Col - 1) * j)) - ((Col - 1) * (j - 1))) Mod (Col)) = 0 Then
                        Frm.Cell(i + ((Col - 1) * j)).Left = Frm.Cell(0).Left 'Si ce sont les cellules du coté gauche
                    Else 'pour les autres cellules, la position se fait par rapport à la précédente
                        Frm.Cell(i + ((Col - 1) * j)).Left = Frm.Cell(i + ((Col - 1) * j) - 1).Left + Frm.Cell(i + ((Col - 1) * j) - 1).Width
                    End If
            End Select
        Next i
        k = k + 1 'Incrémentation du compteur de ligne
    Next j
End Sub

Conclusion :


La finalité de ce projet, serait en fait d'en faire un OCX, mais je n'ai pas encore les connaissances suffisantes dans ce domaine, il faudrait que je me penche sur la question etc. Bref, si quelqu'un taquine les OCX et veut bien en faire un à partir de mon code, j'en serait ravi ^^
Dernière petite chose, les form sont limités en nombre de controles, donc évitez de passer de trop gros tableaux dépassant les 3000 lignes...

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

tbbuim1
Messages postés
940
Date d'inscription
jeudi 20 février 2003
Statut
Membre
Dernière intervention
3 février 2011
7
Merci, mais le code que je propose est un peu compliqué, je suis en train de le simplifier grandement et surtout de faire un module, plutot qu'une fonction dans un form, mise à jour à venir très prochainement...
CADRATURE
Messages postés
26
Date d'inscription
mercredi 26 novembre 2003
Statut
Membre
Dernière intervention
13 juin 2009

Merci et bravo pour ce code

Ces "grids" sont une question qui revient d'une manière périodique dans la vie d'un développeur. Connaître une "grid" dans les détails tel que tu le proposes ici ne peut qu'être que profitable.

Je donne une très bonne note

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.