Visual Basic, VB6, VB.NET, VB 2005, VB CodeS-SourceS

CodeS-SourceS est hébergé par Frontier.fr

Ce site au démarrage

begin process at 2012 02 15 00:33:34

Accueil Codes Tutoriels Forum Livres Emploi Services Connexion

Trouver un code source :

dans

[ Dernières recherches ]

Accueil >

GÉNÉRATEUR DE GRAPHIQUE

Information sur la source

Note :

6,00 / 10

Catégorie :Graphique Classé sous :graphique, histogramme, courbe, statistique, affichage Niveau :Initié Date de création :22/03/2010 Vu / téléchargé :4 588 / 793

Auteur : pascamau

Ecrire un message privé

Commentaire sur cette source (6)

Ajouter un commentaire et/ou une note

Description

Cliquez pour voir la capture en taille normale

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

'***********************
'***** 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

'***********************
'***** 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

Fichier Zip

Les Membres Club peuvent télécharger directement un fichier contenu dans le zip sans télécharger le zip en entier !

Graph
- ClassGraph.cls 2 481 octets
- FrmGraph.frm 22 762 octets
- ModMain.bas 450 octets
- Project1.vbp 731 octets
- Project1.vbw 116 octets

Télécharger le zip

Sources du même auteur

GÉNÉRATEUR DE GRAPHIQUE

FUSION DE CELLULES DANS UN DATAGRIDVIEW

Toutes les sources de pascamau

Sources de la même categorie

VB10 - CRÉER VOS PROPRES CALQUES SUR UNE IMAGE par Duke49

CREER UN GIF ANIMÉ par Le Pivert

GRAPH PHP COURBE DE CHARGE par s.defaye

BOULE DE CRISTAL par BLUEBIBUBBLE

VB6 - DÉPLACEMENT D'UN CONTRÔLE SUR UN SEGMENT DE DROITE DÉL... par ucfoutu

Toutes les sources de la catégorie Graphique

Sources en rapport avec celle ci

GÉNÉRATEUR DE GRAPHIQUE par pascamau

USER CONTROL POUR UN HISTOGRAMME À BARRES VERTICALES par tchconst

HISTOGRAMME - SUITE - GRAPHIQUE DE BARRES VERTICALES POUR UN... par tchconst

GRAPHIQUE 1 À 4 COURBES AVEC MSCHART par mertronic

HISTOGRAMME 2 par Valentino

Commentaires et avis

Commentaire de miiimou le 22/03/2010 21:11:18

OU je dois mettre ce code svp??

Commentaire de pascamau le 23/03/2010 18:12:59

Bonjour,
Le mieux est de telecharger le zip, car il n'ya plus qu'a changer la source de donnée pour générer vos graphiques.

Commentaire de kjoline le 24/03/2010 15:48:02 8/10

Cette source est vraiment terrible! vraiment de l'excellent travail!!
Chapeau l'artiste! je cherchais ce genre de module depuis longtemps!!!

trop content!!

Commentaire de rainstars le 21/08/2010 18:22:53

comprend rien..ou dois mettre ce code?

Commentaire de pascamau le 23/08/2010 09:46:26

Bonjour Rainstars,
Les codes de tous les modules sont listés dans la fenetre source.
Il faut donc recreer les modules et y mettre les codes respectifs ou bien charger le zip où tout le code est déjà saisi.
Cordialement,
P.M.

Commentaire de HACKANDROID le 30/08/2011 23:47:41 4/10

Bien mais explique un peu plus!

Ajouter un commentaire

Discussions en rapport avec ce code source dans le forum

graphique VB.NET (courbe + histogramme) [ par cameleon044 ] Bonjour, Voilà j'ai un petit problème en VB.NET ave cvisual studio 2003 sous windows 2000.Je voudrais faire un graphique avec un histogramme et une co Graphique (courbe - histogramme) VB .Net (Visual Basic 2008 Express) [ par Wenoo ] Bonjour, Je suis actuellement en stage de fin d'année d'étude en Roumanie et je dois réaliser un logiciel à l'aide du VB afin de traiter et récupérer Affichage graphique d'une matrice (labyrinthe) [ par hyougo ] Bonjour, je suis débutant en programmation et je butte sur pas mal de problèmes. Je souhaite réaliser un générateur de labyrinthe. Pour cela je voudra vb.net 2008 graphique et courbe [ par sigrid1983 ] Bonjour à tous,j'ai conscience que ma question a déjà fait le sujet de plusieurs messages, et je m'en excuse.J'utilise VB.NET 2008 depuis peu et je so graphique en VB [ par jarima ] J'ai un programme dans lequel je génère des calculs que je sauvegarde dans un tableau. Je voudrais récupérer les données du tableau pour tracer des co Faire un Graphique avec Access [ par timotep ] Bonjour, voici mon problème :Je désire faire avec access un graphique représentant :2 courbes différentes (2 courbes sur le même graphique)1 courbe do Somme d'une série d'un graphique histogramme dans Access [ par Sunkana ] Bonjour,J'ai créé une bdd Access pour établir des stats. J'ai créé des graphs sous access.Je souhaiterai afficher la somme de Graphique [ par floralies ] Salut à tous !J 'aimerais savoir comment faire un graphique ( courbe et camembert ) dans vb 2005. Les données proviennent d'un listview qui contient d VBA graphique [ par elodie P ] Bonjour,Je suis debutante en VBA et j'aurai besoin d'une aide pour un projet.Sur une feuille graphique de Excelle j'ai un graphique avec une courbe bl Graphique Histogramme [ par Alex200 ] Bonjour,J'aimerais génerer un graphique de type histogramme a 100% selon une série de données. Mon axe des abcisses correspond a 5 personnes différent

Nos sponsors

Derniers Blogs

GESTION D'EXCEPTION AVEC LES TASKS par richardc

DéMARRONS AVEC LES TASKS par richardc

SLIDE & DéMO TECHDAYS 2012 - FAST & FURIOUS XAML APPS par Vko

XNA IS DEAD! par richardc

TECHDAYS PARIS 2012 : WINDOWS SERVER "8" QUOI DE 9 ! par ROMELARD Fabrice

Forum

RE : BESOIN D'AIDE VISUAL BASIC : POURQUOI çA NE FONCTIONNE PAS ? par LIBRE_MAX

RE : BLOCAGE DE MON PROGRAMME par kobeymane

RE : COMMENT UTILISER UNE IMAGELIST DANS UNE LISTVIEW? par ShayW

RE : ANCRAGE D'UN FORMULAIRE DANS UNE TABPAGE. par jimy neutron

RE : FAIRE UN EXECUTABLE par NHenry

Côté IT

Offres d'emploi

Formations Video

Appels d'offres

Simulateur de gravure flash pour medailles avec inscriptions
Budget : 4 000€
Creation d un bandeau publicitaire
Budget : 200€
Realisation site web - gestionnaire de demande de stages
Budget : 10 000€

Logiciels

DocTranslate (V3.1.0.0)
DOCTRANSLATE (V3.1.0.0)

DocTranslate est un traducteur de document Microsoft Word, PowerPoint et Excel. Il permet d'autom...

Cliquez pour télécharger DocTranslate
Tribler (2012)
TRIBLER (2012)

Tribler est un client pair à pair (P2P/Peer-to-Peer) open source avec la capacité de regarder des...

Cliquez pour télécharger Tribler
OneSwarm (2012)
ONESWARM (2012)

Le peer-to-peer qui protège votre vie privée, c'est OneSwarm. Ce logiciel de peer-to-peer crypté...

Cliquez pour télécharger OneSwarm
PONAMEDIA PREMIUM - HELLLOOO FLASH DEMO (V8.4)
PONAMEDIA PREMIUM - HELLLOOO FLASH DEMO (V8.4)

PONAMEDIA TV DEVIENS HELLLOOO FLASH LA TV SUR VOTRE ORDINATEUR. Toute une plateforme Multi...

Cliquez pour télécharger PONAMEDIA PREMIUM - HELLLOOO FLASH DEMO
Academy System (17.2.1.0)
ACADEMY SYSTEM (17.2.1.0)

Logiciel de gestion des établissements. - élèves/étudiants (inscription, dossier, absence...) -...

Cliquez pour télécharger Academy System