Histogramme 2
Description
Ce code permet de générer de l'histogramme
25/09/2003 : La version imprimable prochainement disponible
Source / Exemple :
'Module1.bas
'---------------------------------------------------------------------------------------------
Declare Function EnumFonts Lib "gdi32" Alias "EnumFontsA" (ByVal hdc As Long, ByVal lpsz As String, ByVal lpFontEnumProc As Long, ByVal lParam As Long) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Const LF_FACESIZE = 32
Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Function EnumerateFontProcedure(ByVal lplf As Long, ByVal lptm As Long, ByVal dwType As Long, ByVal lpData As Long) As Long
Dim LF As LOGFONT, FontName As String, ZeroPos As Long
CopyMemory LF, ByVal lplf, LenB(LF)
FontName = StrConv(LF.lfFaceName, vbUnicode)
ZeroPos = InStr(1, FontName, Chr$(0))
If ZeroPos > 0 Then FontName = Left$(FontName, ZeroPos - 1)
Form1.Combo1.AddItem FontName
EnumerateFontProcedure = 1
End Function
'---------------------------------------------------------------------------------------------
'Fin du module
Option Explicit
Dim Tableau1() As Integer 'Tableaux pour l'exemple
Dim Tableau2() As String 'Tableaux pour l'exemple
Dim i As Integer
Dim N As Integer
Function Graph(Titre As String, Largeur As Integer, PosX As Integer, PosY As Integer, Taille As Long, Polices As String, Contour As Byte, Espace As Integer, D3 As Byte, Imprimer As Boolean)
Dim X As Object
Dim j As Integer
If Imprimer Then Set X = Printer Else Set X = Form1
For i = 0 To 14
Randomize
j = Int((100 * Rnd))
Tableau1(i) = j
Tableau2(i) = "Fournisseur" & CStr(i)
Next i
N = 0
If Imprimer = False Then X.Cls
X.FontSize = 8
X.Font = Polices 'La gestion de la police est un gadget
X.ScaleMode = 3
If Imprimer Then
Largeur = Largeur * 50
Taille = Taille * 50
Espace = Espace * 50
End If
X.FillStyle = 0
X.Print Titre
X.Line (PosX, PosY)-(PosX, PosY + Taille)
X.Line (PosX - 2, PosY)-(PosX + 3, PosY)
X.CurrentX = PosX - 30
X.CurrentY = PosY - 5
X.Print "100%"
X.Line (PosX - 2, PosY + Taille / 4)-(PosX + 3, PosY + Taille / 4)
X.CurrentX = PosX - 25
X.CurrentY = PosY + Taille / 4 - 6
X.Print "75%"
X.Line (PosX - 2, PosY + Taille / 2)-(PosX + 3, PosY + Taille / 2)
X.CurrentX = PosX - 25
X.CurrentY = PosY + Taille / 2 - 6
X.Print "50%"
X.Line (PosX - 2, PosY + Taille - Taille / 4)-(PosX + 3, PosY + Taille - Taille / 4)
X.CurrentX = PosX - 25
X.CurrentY = PosY + Taille - Taille / 4 - 6
X.Print "25%"
X.Line (PosX - 2, PosY + Taille)-(PosX + 3, PosY + Taille)
X.CurrentX = PosX - 19
X.CurrentY = PosY + Taille - 6
X.Print "0%"
X.FontSize = 6
For i = 0 To UBound(Tableau1)
N = N + 1
If Imprimer Then
X.FillColor = RGB(Rnd * 255, Rnd * 255, Rnd * 255)
X.Line (PosX + (Largeur + Espace) * N, PosY + Taille)-Step(Largeur, -(Tableau1(i) * Taille) / 100), , B
X.CurrentX = (PosX + (Largeur + Espace) * N + (Largeur / 2))
X.CurrentY = PosY + Taille + 3
X.Print CStr(i)
Else
On Error Resume Next
Load Label1(N)
Label1(N).Width = Largeur
Label1(N).Left = PosX + (Largeur + Espace) * N
Label1(N).Height = (Tableau1(i) * Taille) / 100
Label1(N).BorderStyle = Contour
Label1(N).Appearance = D3
Label1(N).BackColor = RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Label1(N).Top = PosY + Taille - ((Tableau1(i) * Taille) / 100)
Label1(N).ToolTipText = Tableau2(i) + " " + CStr(Tableau1(i)) + "%" 'Par ex
Label1(N).Visible = True
X.CurrentX = Label1(N).Left + Largeur / 2 - Largeur / 10
X.CurrentY = PosY + Taille + 5
X.Print CStr(N)
End If
Next i
If Imprimer Then
X.Line (PosX, PosY + Taille)-(X.CurrentX + Largeur + 5, PosY + Taille)
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
X.EndDoc
Else
X.Line (PosX, PosY + Taille)-(Label1(N).Left + Largeur + 5, PosY + Taille)
End If
End Function
Private Sub Command1_Click()
Call Graph("Test taille " + CStr(HS1.Value), HS4.Value, HS2.Value, HS3.Value, HS1.Value, Combo1.Text, Check1.Value, HS5.Value, Check2.Value, False)
End Sub
Private Sub Command2_Click()
Call Graph("Test taille " + CStr(HS1.Value), HS4.Value / 5, HS2.Value, HS3.Value, HS1.Value / 5, Combo1.Text, Check1.Value, HS5.Value / 5, Check2.Value, True)
End Sub
Private Sub Form_Activate()
Call Graph("Test taille 300", 20, 100, 100, 300, "Arial", 1, 1, 0, False)
End Sub
Private Sub Form_Load()
Me.AutoRedraw = True 'Important
Me.ScaleMode = 6 'Millimétre
EnumFonts Me.hdc, vbNullString, AddressOf EnumerateFontProcedure, 0
Combo1.Text = "Arial"
'EXEMPLE ---------------------------
ReDim Tableau1(14)
ReDim Tableau2(14)
'------------------------------------
End Sub
Private Sub HS1_Change()
Frame1.Caption = "Taille : " + CStr(HS1.Value)
End Sub
Private Sub HS2_Change()
Frame2.Caption = "PosX : " + CStr(HS2.Value)
End Sub
Private Sub HS3_Change()
Frame3.Caption = "PosY : " + CStr(HS3.Value)
End Sub
Private Sub HS4_Change()
Frame4.Caption = "Largeur : " + CStr(HS4.Value)
End Sub
Private Sub HS5_Change()
Frame7.Caption = "Espace : " + CStr(HS5.Value)
End Sub
Private Sub Label1_DblClick(Index As Integer)
MsgBox "DblClick sur la barre N°" + CStr(Index) 'Vous pouvez gerer les évenements pour chaque label de façon individuelle ou commune
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² ::.
Conclusion :
25/09/2003 : La version imprimable prochainement disponible
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.