Histogramme 2

1/5 (8 avis)

Vue 10 625 fois - Téléchargée 1 064 fois

Description

Ce code permet de générer de l'histogramme

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

Codes Sources

A voir également

Ajouter un commentaire Commentaires
Messages postés
81
Date d'inscription
vendredi 19 juillet 2002
Statut
Membre
Dernière intervention
3 août 2010

Bonjour,
Effectivement la gestion de l'erreur n'est pas des plus élégantes, cependant largement suffisante pour cet exemple.
Si tu le souhaite, intercepte les codes erreur et interagis suivant chaque cas de figure...
Comme notifié ce code n'est qu'une base.
Merci pour tes remarques
Bonne prog
Messages postés
406
Date d'inscription
lundi 9 juin 2003
Statut
Membre
Dernière intervention
4 septembre 2013
1
D'accord je viens de m'appercevoir que le code ne correspond pas au ZIP.

Tu utilise un "on error resume next" pour masque l'erreur
Je n'aime pas bien cette fonction cache misere.
N'y a t'il pas moyen de tester si l'objet est déjà chargé avec un simple condition?

Merci de vos reponses
Messages postés
406
Date d'inscription
lundi 9 juin 2003
Statut
Membre
Dernière intervention
4 septembre 2013
1
Bonjour

Moi, j'ai un message d'erreur "objet deja chargé" quand je clique "afficher"
Messages postés
81
Date d'inscription
vendredi 19 juillet 2002
Statut
Membre
Dernière intervention
3 août 2010

Non toujours pas imprimable... j'ai un début de code mais malheuresement mon emploi du temps me permet pas de finir tout ce que je souhaite. :o/
Cependant j'ai l'intention d'y remédier prochainement ;o)
Ciao
Messages postés
1133
Date d'inscription
mercredi 2 octobre 2002
Statut
Membre
Dernière intervention
24 juillet 2011
3
Toujours pas de version imprimable ?
Afficher les 8 commentaires

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.