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
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.