Générateur de graphique

Télécharger le projet
Commenter

Description

Un petit générateur de graphique très simple à mettre en oeuvre.
Il vous suffit de partir du zip ou de copier le code dans les Form, Module et Class module.
Il reste l'instanciation multi-fenêtre à créer, car le Form ne prend qu'une instance de graphique en simultané.

Source / Exemple : 


'***********************
'***** Module Main *****
'***********************
Public Sub Main()
    Dim i, j As Integer
    Dim g1 As ClassGraph
    Set g1 = New ClassGraph
    Dim jour As String
           
    g1.ClearStructure
    g1.SetTitle "Demo graph"
    g1.SetCibleValue 5, "Cible :"
    
    For i = 1 To 30
        g1.AddValue Rnd(10) * 7 + 1, Format(Now() - 30 + i, "dd/mm")
    Next i
            
    FrmGraph.InitGraph g1
    FrmGraph.Show 1
    
     
End Sub

'**********************************************************************************
'****                             Module Class graphique                      *****
'**********************************************************************************

Option Explicit

Private Type StructGraph
    titreGraph As String
    
    nbValue As Integer
    
    values() As Double
          
    
    pS() As Shape
    
    ligneCible As Line
       
    libelleCible As String
    cible As Double
    
    pLabelValues() As String
    pLabelAbscisse() As String
    
End Type

Private sg As StructGraph

Public Sub ClearStructure()
    sg.nbValue = 0
    sg.titreGraph = ""
    sg.cible = 0
    
End Sub

Public Sub AddValue(ByVal valeur As Double, ByVal valeurAbcisse As String)
    
    

    ReDim Preserve sg.pLabelValues(0 To sg.nbValue)
    ReDim Preserve sg.pLabelAbscisse(0 To sg.nbValue)
    ReDim Preserve sg.pS(0 To sg.nbValue)
    ReDim Preserve sg.values(0 To sg.nbValue)
    
    sg.values(sg.nbValue) = valeur
    sg.pLabelAbscisse(sg.nbValue) = valeurAbcisse
    sg.pLabelValues(sg.nbValue) = FormatNumber(valeur, 0)
    
    sg.nbValue = sg.nbValue + 1
    
End Sub

Public Sub SetTitle(ByVal title As String)
    sg.titreGraph = title
End Sub

Public Sub SetCibleValue(ByVal valeur As Double, ByVal libelleCible As String)
    sg.cible = valeur
    sg.libelleCible = libelleCible & FormatNumber(valeur, 0)
End Sub
Public Function GetNbValues() As Integer
    GetNbValues = sg.nbValue
End Function

Public Function GetCible() As Double
    GetCible = sg.cible
End Function

Public Function GetLibelleCible() As String
    GetLibelleCible = sg.libelleCible
End Function

Public Function GetValue(ByVal i As Integer) As Double
    GetValue = sg.values(i)
End Function

Public Function GetLabelValue(ByVal i As Integer) As String
    GetLabelValue = sg.pLabelValues(i)
End Function

Public Function GetTitle() As String
    GetTitle = sg.titreGraph
End Function

Public Function GetLabelAbcisseValue(ByVal i As Integer) As String
    GetLabelAbcisseValue = sg.pLabelAbscisse(i)
End Function

'**********************************************************************************
'****                             Graphic wondow                              *****
'**********************************************************************************
ption Explicit

Private IsAlreadyOpen As Boolean

Private Type StructGraph
    titreGraph As String
    
    nbValue As Integer
    
    values() As Double
          
    
    pS() As Shape
    
    ligneCible As Line
       
    libelleCible As String
    cible As Double
    
    pLabelValues() As Label
    pLabelAbscisse() As Label
    
End Type

Dim pasLblCible As Integer
Dim AfficherSignature As Boolean

Dim rouge, vert, bleu As Integer
Dim ligneActuelleSignature As Integer

Dim ligneSignature() As String

Private graphOE As ClassGraph

Private cCurGraph As ClassGraph

Private sg As StructGraph

Private li() As Line
Private maxValue As Integer

Public Sub InitGraph(ByRef sG_OE As ClassGraph)
    Dim i As Integer
       
    IsAlreadyOpen = False
       
    Set graphOE = sG_OE
    
    
    Set cCurGraph = graphOE
    test
    
    Set cCurGraph = graphOE
        
    
End Sub

Private Sub ChkBordure_Click()
    If maxValue > 0 Then RedrawGraphHisto
End Sub

Private Sub ChkFill_Click()
    If maxValue > 0 Then RedrawGraphHisto
End Sub

Private Sub CmdChgTypeGraph_Click()
    Dim i As Integer
    
    If CmdChgTypeGraph.Caption = "Histogramme" Then
        RedrawGraphHisto
        CmdChgTypeGraph.Caption = "Courbe"
        ChkBordure.Visible = True
        ChkFill.Visible = True
        For i = 0 To sg.nbValue - 1
            li(i).Visible = False
            sg.pS(i).Visible = True
        Next i
    Else
        RedrawGraphLine
        CmdChgTypeGraph.Caption = "Histogramme"
        ChkBordure.Visible = False
        ChkFill.Visible = False
        For i = 0 To sg.nbValue - 1
            li(i).Visible = True
            sg.pS(i).Visible = False
        Next i
        
    End If
    
End Sub

Private Sub CmdClose_Click()
    Unload Me
End Sub

Private Sub CmdPrint_Click()
    Dim X, Y As Long
    
    X = FrmGraph.Width
    Y = FrmGraph.Height
     
    
    FrmGraph.Width = 16500
    FrmGraph.Height = 12200
    
    LblSite.Visible = True
    LblDate.Visible = True
    LblVersion.Visible = True
    
    CmdPrint.Visible = False
    CmdChgTypeGraph.Visible = False
    CmdClose.Visible = False
    ChkToolTip.Visible = False
    
    LblSite = "Graph démo"
    LblDate = "Le " & Format(Now(), "dd.mm/yyyy hh:mm:ss")
    LblVersion = "Pascal Mauran"
    
    Printer.Orientation = 2
    FrmGraph.PrintForm
    Printer.EndDoc
    
    LblSite.Visible = False
    LblDate.Visible = False
    LblVersion.Visible = False
    
    CmdPrint.Visible = True
    CmdChgTypeGraph.Visible = True
    CmdClose.Visible = True
    ChkToolTip.Visible = True
    
    FrmGraph.Width = X
    FrmGraph.Height = Y
    
End Sub

Private Sub Form_Load()
    Dim l As Long
    
    maxValue = 0
    IsAlreadyOpen = False
        
    LblCible.BackStyle = 0
    
    FrmGraph.BackColor = RGB(240, 240, 240)
    
    LblCible.Left = 10
    LblCible.ForeColor = RGB(0, 0, 200)
    ChkToolTip.BackColor = RGB(240, 240, 240)
    ChkToolTip.ForeColor = RGB(0, 0, 200)
    ChkBordure.ForeColor = RGB(0, 0, 200)
    ChkBordure.BackColor = RGB(240, 240, 240)
    ChkFill.BackColor = RGB(240, 240, 240)
    ChkFill.ForeColor = RGB(0, 0, 200)
    ChkBordure.Visible = False
    ChkFill.Visible = False
        
    ChkBordure.value = 1
    ChkFill.value = 1
    
End Sub

Public Sub RedrawGraphHisto()
    Dim X, Y, largeur, hauteur, i, value As Long
    
    Dim s As Shape
    Dim l As Line
    
    Dim maxSize As Integer
    maxSize = 700
    
    
    LblTitre.Alignment = vbCenter
    LblTitre = sg.titreGraph
    LblTitre.FontName = "Arial"
    LblTitre.FontSize = FrmGraph.Width / 620
    LblTitre.Height = LblTitre.FontSize * 23
    LblTitre.Width = FrmGraph.Width - 300
    LblTitre.FontBold = True
    LblTitre.BorderStyle = 0
    LblTitre.Left = 100
    LblTitre.ForeColor = RGB(100, 100, 255)
    
    LblCible.FontName = "Arial"
    LblCible.Height = LblTitre.FontSize * 21
    LblCible.Alignment = vbCenter
    LblCible.BorderStyle = 1
    LblCible = cCurGraph.GetLibelleCible
    
    
    If sg.nbValue > 0 Then
        
        largeur = (FrmGraph.Width - 1000) / sg.nbValue
        X = 500 ' largeur + 50
        
        Y = LblTitre.Top + LblTitre.Height + 500
        
        hauteur = FrmGraph.Height - Y - 1500
        
        'Affichage des barres
        For i = 0 To sg.nbValue - 1
            If sg.values(i) > maxValue Then
                value = hauteur
            Else
                value = Int((hauteur / maxValue) * sg.values(i))
            End If
            sg.pS(i).Visible = True
            sg.pS(i).FillStyle = 0
            sg.pS(i).Left = X + (i * largeur)
            
            sg.pS(i).Width = largeur
            
                        
            sg.pS(i).Top = Y + (hauteur - value)
                                   
            If value > 0 Then
                sg.pS(i).Height = value
                                        
                sg.pS(i).BorderWidth = 1
                sg.pS(i).BorderColor = RGB(0, 0, 0)
                
                            
                'Affichage des bordures
                sg.pS(i).BorderWidth = 2
                If ChkBordure = 1 Then
                    sg.pS(i).BorderColor = RGB(0, 0, 0)
                Else
                    If sg.values(i) >= sg.cible Then
                        sg.pS(i).BorderColor = RGB(0, 200, 0)
                    Else
                        sg.pS(i).BorderColor = RGB(255, 80, 80)
                    End If
                End If
                
                'Coloration des barres
                If ChkFill = 1 Then
                    If sg.values(i) >= sg.cible Then
                        sg.pS(i).FillColor = RGB(0, 200, 0)
                    Else
                        sg.pS(i).FillColor = RGB(255, 80, 80)
                    End If
                Else
                    sg.pS(i).FillColor = RGB(240, 240, 255)
                End If
            End If
            
        Next i
        
        
        
        'Affichage de la cible
        value = (hauteur / maxValue) * sg.cible
                
        sg.ligneCible.BorderStyle = 5
        
        sg.ligneCible.BorderColor = RGB(120, 255, 120)
        sg.ligneCible.BorderColor = RGB(0, 0, 0)
        sg.ligneCible.Visible = True
        sg.ligneCible.X1 = X
        sg.ligneCible.X2 = FrmGraph.Width - 500
        sg.ligneCible.Y1 = Y + (hauteur - value)
        sg.ligneCible.Y2 = Y + (hauteur - value)
                
        
        If maxSize > largeur And largeur > 70 Then
            LblCible.FontSize = largeur / 40 '90
        Else
            LblCible.FontSize = maxSize / 40 '90
        End If
        
        LblCible.Height = LblCible.FontSize * 27
        LblCible.Top = Y + (hauteur - value) - (LblCible.Height / 2)
        LblCible.FontBold = True
        LblCible.Width = Len(LblCible.Caption) * (LblCible.FontSize * 12)
        
        LblCible.BorderStyle = 0
        
        'Affichage des valeurs
        For i = 0 To sg.nbValue - 1
             sg.pLabelValues(i).FontName = "Arial"
             If maxSize > largeur Then
                sg.pLabelValues(i).FontSize = largeur / 55 '75
             Else
                sg.pLabelValues(i).FontSize = maxSize / 55 '75
             End If
                         
             value = (hauteur / maxValue) * sg.values(i)
             sg.pLabelValues(i).Visible = True
             sg.pLabelValues(i).Alignment = vbCenter
             
             sg.pLabelValues(i).Height = sg.pLabelValues(i).FontSize * 70
             sg.pLabelValues(i).Width = largeur
             
             If sg.values(i) > maxValue Then
                 sg.pLabelValues(i).Top = Y
             Else
                 sg.pLabelValues(i).Top = Y + (hauteur - value) '+ sg.pLabelValues(i).Height
             End If
             
             sg.pLabelValues(i).Left = X + (i * largeur)
             sg.pLabelValues(i).ForeColor = RGB(0, 0, 0)
             
        Next i
    
        
        'Affichage des abscisses
        For i = 0 To sg.nbValue - 1
            sg.pLabelAbscisse(i).ForeColor = RGB(0, 0, 200)
            sg.pLabelAbscisse(i).FontName = "Arial"

            If maxSize > largeur Then
                sg.pLabelAbscisse(i).FontSize = largeur / 60 '(60 + ((FrmGraph.Height - Y - hauteur) / 50))
            Else
                sg.pLabelAbscisse(i).FontSize = maxSize / 60
            End If
            
            sg.pLabelAbscisse(i).Visible = True
            sg.pLabelAbscisse(i).Alignment = vbCenter
            
            sg.pLabelAbscisse(i).Height = sg.pLabelValues(i).FontSize * 60
            sg.pLabelAbscisse(i).Width = largeur
            
            sg.pLabelAbscisse(i).Left = X + (i * largeur)
            sg.pLabelAbscisse(i).Top = Y + hauteur + 200
            
            
        Next i
        
    End If
End Sub

Public Sub test()
    Dim i As Integer
    
    If IsAlreadyOpen = True Then
        If sg.nbValue > 0 Then
            For i = 0 To sg.nbValue - 1
                Call Controls.Remove("Shape" & i)
                Call Controls.Remove("Label" & i)
                Call Controls.Remove("LabelAbs" & i)
            Next i
            Call Controls.Remove("Line1")
        End If
    End If
        
    sg.nbValue = cCurGraph.GetNbValues
    sg.titreGraph = cCurGraph.GetTitle
    ReDim sg.pS(0 To sg.nbValue - 1)
    ReDim sg.pLabelValues(0 To sg.nbValue - 1)
    ReDim sg.values(0 To sg.nbValue - 1)
    ReDim sg.pLabelAbscisse(0 To sg.nbValue - 1)
    
    sg.cible = cCurGraph.GetCible
    sg.libelleCible = cCurGraph.GetLibelleCible
    
    
    Set sg.ligneCible = FrmGraph.Controls.Add("vb.Line", "Line1")
    
    ReDim li(0 To sg.nbValue)
    maxValue = sg.cible
    For i = 0 To sg.nbValue - 1
        Set sg.pLabelValues(i) = FrmGraph.Controls.Add("vb.Label", "Label" & i)
        Set sg.pLabelAbscisse(i) = FrmGraph.Controls.Add("vb.Label", "LabelAbs" & i)
        Set sg.pS(i) = FrmGraph.Controls.Add("vb.shape", "Shape" & i)
        sg.values(i) = cCurGraph.GetValue(i)
        
        sg.pLabelValues(i) = cCurGraph.GetLabelValue(i)
        sg.pLabelValues(i).BackStyle = 0
        sg.pLabelValues(i).FontBold = True
                
        
        sg.pLabelAbscisse(i) = cCurGraph.GetLabelAbcisseValue(i)
        
        sg.pLabelAbscisse(i).BackStyle = 0
        sg.pLabelAbscisse(i).FontBold = True
        
        Set li(i) = FrmGraph.Controls.Add("vb.Line", "L" & i)
        li(i).BorderStyle = 2
        li(i).BorderWidth = 2
        li(i).BorderColor = RGB(0, 0, 255)
        li(i).Visible = True
        
        If maxValue < sg.values(i) Then maxValue = sg.values(i)
    Next i
    
        
    IsAlreadyOpen = True
            
    FrmGraph.Width = Screen.Width
    FrmGraph.Height = Screen.Height
    
End Sub

Private Sub Form_Resize()
    
    If CmdChgTypeGraph.Caption = "Histogramme" Then
        If FrmGraph.Height > 2000 And FrmGraph.Width > 2000 Then RedrawGraphLine
    Else
        If FrmGraph.Height > 2000 And FrmGraph.Width > 2000 Then RedrawGraphHisto
    End If
    
End Sub

Public Sub RedrawGraphLine()
    Dim X, Y, largeur, hauteur, i, value As Long
    
    Dim s As Shape
    Dim l As Line
    
    Dim maxSize As Integer
    maxSize = 700
    
    If IsAlreadyOpen = True Then
        LblTitre.Alignment = vbCenter
        LblTitre = sg.titreGraph
        LblTitre.FontName = "Arial"
        LblTitre.FontSize = FrmGraph.Width / 620
        LblTitre.Height = LblTitre.FontSize * 23
        LblTitre.Width = FrmGraph.Width - 300
        LblTitre.FontBold = True
        LblTitre.BorderStyle = 0
        LblTitre.Left = 100
        LblTitre.ForeColor = RGB(100, 100, 255)
        
        LblCible.FontName = "Arial"
        LblCible.Height = LblTitre.FontSize * 21
        LblCible.Alignment = vbCenter
        LblCible.BorderStyle = 1
        LblCible = cCurGraph.GetLibelleCible
        
        
        If sg.nbValue > 0 Then
            
            largeur = (FrmGraph.Width - 1000) / sg.nbValue
            X = 500 ' largeur + 50
            
            Y = LblTitre.Top + LblTitre.Height + 500
            
            hauteur = FrmGraph.Height - Y - 1500
            
            
            'Affichage des barres
            For i = 0 To sg.nbValue - 2
                If sg.values(i) > 100 Then
                    value = hauteur
                Else
                    value = Int((hauteur / maxValue) * sg.values(i))
                End If
                
                sg.pS(i).Left = X + (i * largeur)
                sg.pS(i).Width = largeur
                sg.pS(i).Top = Y + (hauteur - value)
                sg.pS(i).Height = value
                
                li(i).X1 = X + (i * largeur) + largeur / 2
                li(i).X2 = X + ((i + 1) * largeur) + largeur / 2
                li(i).Y1 = Y + (hauteur - value)
                li(i).Y2 = Y + (hauteur - Int((hauteur / maxValue) * sg.values(i + 1)))
                
            Next i
            
            
            'Affichage de la cible
            value = (hauteur / maxValue) * sg.cible
            
            sg.ligneCible.BorderStyle = 5
            
            sg.ligneCible.BorderColor = RGB(120, 255, 120)
            sg.ligneCible.BorderColor = RGB(0, 0, 0)
            sg.ligneCible.Visible = True
            sg.ligneCible.X1 = X
            sg.ligneCible.X2 = FrmGraph.Width - 500
            sg.ligneCible.Y1 = Y + (hauteur - value)
            sg.ligneCible.Y2 = Y + (hauteur - value)
                    
            
            If maxSize > largeur Then
                LblCible.FontSize = largeur / 40 '90
            Else
                LblCible.FontSize = maxSize / 40 '90
            End If
            
            LblCible.Height = LblCible.FontSize * 27
            LblCible.Top = Y + (hauteur - value) - (LblCible.Height / 2)
            LblCible.FontBold = True
            LblCible.Width = Len(LblCible.Caption) * (LblCible.FontSize * 12)
            
            LblCible.BorderStyle = 0
            
            'Affichage des valeurs
            For i = 0 To sg.nbValue - 1
                 sg.pLabelValues(i).FontName = "Arial"
                 If maxSize > largeur Then
                    sg.pLabelValues(i).FontSize = largeur / 55 '75
                 Else
                    sg.pLabelValues(i).FontSize = maxSize / 55 '75
                 End If
                             
                 value = (hauteur / maxValue) * sg.values(i)
                 sg.pLabelValues(i).Visible = True
                 sg.pLabelValues(i).Alignment = vbCenter
                 
                 sg.pLabelValues(i).Height = sg.pLabelValues(i).FontSize * 70
                 sg.pLabelValues(i).Width = largeur
                 
                 If sg.values(i) > maxValue Then
                     sg.pLabelValues(i).Top = Y
                 Else
                     sg.pLabelValues(i).Top = Y + (hauteur - value) '+ sg.pLabelValues(i).Height
                 End If
                 
                 sg.pLabelValues(i).Left = X + (i * largeur)
                 sg.pLabelValues(i).ForeColor = RGB(0, 0, 0)
                 
            Next i
        
            
            'Affichage des abscisses
            For i = 0 To sg.nbValue - 1
                sg.pLabelAbscisse(i).ForeColor = RGB(0, 0, 200)
                sg.pLabelAbscisse(i).FontName = "Arial"
                If maxSize > largeur Then
                    sg.pLabelAbscisse(i).FontSize = largeur / 60 '(60 + ((FrmGraph.Height - Y - hauteur) / 50))
                Else
                    sg.pLabelAbscisse(i).FontSize = maxSize / 60
                End If
                
                sg.pLabelAbscisse(i).Visible = True
                sg.pLabelAbscisse(i).Alignment = vbCenter
                
                sg.pLabelAbscisse(i).Height = sg.pLabelValues(i).FontSize * 60
                sg.pLabelAbscisse(i).Width = largeur
                
                sg.pLabelAbscisse(i).Left = X + (i * largeur)
                sg.pLabelAbscisse(i).Top = Y + hauteur + 200
                
                
            Next i
        End If
    End If
    
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim i As Integer
    Dim message As String
    LblToolTip.Visible = False
    
    If ChkToolTip = 1 Then
        For i = 0 To sg.nbValue - 1
            If X > sg.pS(i).Left And X < (sg.pS(i).Left + sg.pS(i).Width) And _
               Y > LblTitre.Top + LblTitre.Height And Y < (sg.pS(i).Height + sg.pS(i).Top) Then
               
               message = FormatNumber(sg.values(i), 0) & " le " & sg.pLabelAbscisse(i)
               LblToolTip.Visible = True
               LblToolTip.Caption = message
               LblToolTip.Left = X + 200
               LblToolTip.Top = Y + 200
               
               If Val(sg.pLabelValues(i)) <= sg.cible Then
                    LblToolTip.ForeColor = RGB(0, 0, 0)
                    LblToolTip.BackColor = RGB(0, 255, 0)
               Else
                    LblToolTip.ForeColor = RGB(255, 255, 255)
                    LblToolTip.BackColor = RGB(255, 0, 0)
               End If
               
            End If
        Next i
    End If
    
End Sub
Télécharger le projet

Codes Sources

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 (pascamau)