HISTOGRAMME

Option Explicit

Dim Tableau1() As Integer 'J'aurais bien voulu utiliser un tableau multidimension du type Tableau(14,1)
Dim Tableau2() As String  'mais on ne peut redimensionner ce genre de tableau
                          'Cependant pour ceux qui peuvent exploiter des tables à taille fixe c'est possible
Dim i As Integer
Dim taille As Integer

Function Graph(Largeur As Integer, Titre As String, Ecran As Boolean)
    Dim X As Object
    If Ecran Then Set X = Form1 Else Set X = Printer
    If Ecran Then X.Cls
    X.Font = "Arial"
    X.ScaleMode = 6
    X.FillStyle = 0
    X.Print Titre
    X.Line (20, 20)-(20, 120)
    X.Line (19, 20)-(21, 20)
    X.CurrentX = 12
    X.CurrentY = 18
    X.Print "100%"
    X.Line (19, 45)-(21, 45)
    X.CurrentX = 13
    X.CurrentY = 43
    X.Print "75%"
    X.Line (19, 70)-(21, 70)
    X.CurrentX = 13
    X.CurrentY = 68
    X.Print "50%"
    X.Line (19, 95)-(21, 95)
    X.CurrentX = 13
    X.CurrentY = 93
    X.Print "25%"
    X.Line (19, 120)-(21, 120)
    X.CurrentX = 14
    X.CurrentY = 118
    X.Print "0%"
    X.FontSize = 6
    For i = 0 To UBound(Tableau1)
        X.FillColor = RGB(Rnd * 255, Rnd * 255, Rnd * 255) 'Il serait facile d'installer une legende avec la couleur juste avec un tableau supplementaire
        X.Line (25 + i * Largeur * 2, 120)-Step(Largeur, -Tableau1(i)), , B
        X.CurrentX = (25 + (Largeur / 2)) + i * Largeur * 2
        X.CurrentY = 123
        X.Print CStr(i)
    Next i
    X.Line (20, 120)-(22 + i * Largeur * 2, 120)
    X.Print
    X.Print
    X.Print
    X.Print
    For i = 0 To UBound(Tableau1)
        X.Print "N°" + CStr(i) + "  " + Tableau2(i) + "  " + CStr(Tableau1(i)) + "%" 'Vous pouvez afficher les valeurs dans une List ou un ListView par ex.
    Next i
    If Ecran = False Then X.EndDoc
End Function

Private Sub Command1_Click()
'Impression du graphique
taille = 190 / (2 * (UBound(Tableau1) + 1)) ' Autosize pour du A4 (210x297)
Call Graph(taille, "Test", False)
End Sub

Private Sub Form_Activate()
'Affichage du graphique
taille = (Me.ScaleWidth - 30) / (2 * (UBound(Tableau1) + 1)) ' Vous pouvez aussi adapter la taille en hauteur
Call Graph(taille, "Test", True)
End Sub

Private Sub Form_Load()
    Me.AutoRedraw = True 'Important pour l'affichage
    Me.ScaleMode = 6 'Millimétre
    'EXEMPLE ---------------------------
    ReDim Tableau1(14)
    ReDim Tableau2(14)
    Tableau1(0) = 64
    Tableau2(0) = "Fournisseur1"
    Tableau1(1) = 25
    Tableau2(1) = "Fournisseur2"
    Tableau1(2) = 89
    Tableau2(2) = "Fournisseur3"
    Tableau1(3) = 17
    Tableau2(3) = "Fournisseur4"
    Tableau1(4) = 100
    Tableau2(4) = "Fournisseur5"
    Tableau1(5) = 65
    Tableau2(5) = "Fournisseur6"
    Tableau1(6) = 2
    Tableau2(6) = "Fournisseur7"
    Tableau1(7) = 94
    Tableau2(7) = "Fournisseur8"
    Tableau1(8) = 52
    Tableau2(8) = "Fournisseur9"
    Tableau1(9) = 15
    Tableau2(9) = "Fournisseur10"
    Tableau1(10) = 8
    Tableau2(10) = "Fournisseur11"
    Tableau1(11) = 77
    Tableau2(11) = "Fournisseur12"
    Tableau1(12) = 32
    Tableau2(12) = "Fournisseur13"
    Tableau1(13) = 29
    Tableau2(13) = "Fournisseur14"
    Tableau1(14) = 90
    Tableau2(14) = "Fournisseur15"
    '-------------------------------- ----
End Sub

Private Sub Form_Resize()
taille = (Me.ScaleWidth - 30) / (2 * (UBound(Tableau1) + 1)) ' Autosize pour du A4 (210x297). Le mode paysage est exploitable si on veut
Call Graph(taille, "Test", True)
End Sub

'Ce code peut être largement amélioré. C'est juste une base pour ceux qui ne veulent pas utiliser l'OCX

'Valentino .:: J² ::.

Télécharger le zip