vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
sevAniGif - als kostenlose Vollversion auf unserer vb@rchiv CD Vol.5  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Newsletter  | Impressum  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2014
 
zurück
Rubrik: Grafik und Font · Sonstiges   |   VB-Versionen: VB4, VB5, VB611.01.05
Kreisdiagramme mit VB-Boardmitteln

Anzeigen von Kreis-, Torten-, Scheibengrafiken mit reinen VB-Boardmitteln

Autor:   Thomas GollmerBewertung:     [ Jetzt bewerten ]Views:  8.276 
ohne HomepageSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8 Beispielprojekt auf CD 

Für kleine Projekte, bei denen das Einbinden von MSChart & Co. überflüssig erscheint, kann man sich mit diesem Code fix ein Kreisdiagramm anzeigen lassen.

Verschiedene Einstellungen beeinflussen das Aussehen. Vom normalen Kreis über eine Torte bis zu übereinander geschichteten Kreisscheiben kann das Erscheinungsbild variabel angepaßt werden.

Hier nun der Code:

Private Sub Torte_Zeichnen( _
  Ein_Werte() As Integer, _
  Kreis_Farben() As Long, _
  Kreis_Größe As Integer, _
  Kreis_Mitte_X As Integer, _
  Kreis_Mitte_Y As Integer, _
  Start_Position As Integer, _
  Ein_Name() As String, _
  Legende_X As Integer, _
  Legende_Y As Integer, _
  Legende_Farbe As Long, _
  Legende_Anzahl_Zeigen As Boolean, _
  Aufsteigend As Boolean, _
  Ellipse As Single, _
  Höhe As Integer, _
  Abstand As Integer, _
  Farbe_3D As Long, _
  Ringe As Boolean, _
  Zeichen_Obj As Object)
 
  ' Werte die Übergeben werden müssen
  ' X und Y Positionen immer in Pixeln
  ' 1.  Variablenfeld der Anzahlen
  ' 2.  Variablenfeld der Farben
  ' 3.  Größe des Kreises
  ' 4.  Startposition des ersten Eintages 0 bis 360 Grad
  '     Bei 0   beginnt das erste Tortenstück rechts
  '     Bei 90  beginnt das erste Tortenstück oben
  '     Bei 180 beginnt das erste Tortenstück links
  '     Bei 270 beginnt das erste Tortenstück unten
  ' 5.  X Position Mitte des Kreises
  ' 6.  Y Position Mitte des Kreises
  ' 7.  Variablenfeld der Bezeichnungen
  ' 8.  X Position der Legende
  ' 9.  Y Position der Legende
  ' 10. die Farbe der Schrift der Legende
  ' 11. Ein True wenn die Anzahl in der Legende stehen soll, wenn nicht ein False
  ' 12. Ein True wenn die Ordnung der Legende aufsteigend ist sonst False
  ' 13. Seitenverhältniss der Ellipse/ des Kreises (0-1)
  ' 14. Höhe der Torte
  ' 15. Abstand äußeren Ringe
  ' 16. Farbe der aüßeren Ringe
  ' 17. True wenn die Ringe gemalt werden sollen, wenn nicht Flase
  ' 18. das Steuerelement auf das gezeichnet werden soll. Eine Form oder PictureBox
 
  Const Pi = 3.14159265358979
 
  Dim Werte_Gesamt As Long
  Dim zähler As Long
  Dim Hilfszähler As Integer
  Dim Temp As Double
  Dim Gesamt_Winkel As Double
  Dim Filmanzahl() As Double
  Dim Temp_Name As String
  Dim Temp_Zahl As Double
  Dim Werte() As Double
  Dim Legende_Bezeichner() As String
  Dim Text_Anzahl As String
 
  ' Mit der Schrift "Courier New" erfolgt die Ausgabe der Legende
  ' schön untereinander
  Zeichen_Obj.ScaleMode = 3
  Zeichen_Obj.Font = "Courier New"
 
  Hilfszähler = 0
  ' Wenn die Summe der übergebenen Werte = 0 dann verlassen ohne Grafikaufbau
  For zähler = LBound(Ein_Werte()) To UBound(Ein_Werte())
    Hilfszähler = Hilfszähler + Ein_Werte(zähler)
  Next zähler
  If Hilfszähler = 0 Then Exit Sub
 
  ' Erst mal das übergebene Variablenfeld ordnen
  ' zu erst die Max bis hin zum Min
  For Hilfszähler = 0 To (UBound(Ein_Werte())) + 1
    For zähler = 1 To UBound(Ein_Werte())
      ' wenn erster Eintrag kleiner tauschen sonst nicht
      If Ein_Werte(zähler - 1) < Ein_Werte(zähler) Then
        Temp_Zahl = Ein_Werte(zähler - 1)
        Temp_Name = Ein_Name(zähler - 1)
        Ein_Werte(zähler - 1) = Ein_Werte(zähler)
        Ein_Name(zähler - 1) = Ein_Name(zähler)
        Ein_Werte(zähler) = Temp_Zahl
        Ein_Name(zähler) = Temp_Name
      End If
    Next zähler
  Next Hilfszähler
 
  ' Felder, deren Wert = 0 ist entfernen und nicht mit anzeigen
  Hilfszähler = 0
  For zähler = LBound(Ein_Werte()) To UBound(Ein_Werte())
    If Ein_Werte(zähler) = 0 Then Exit For
    Hilfszähler = Hilfszähler + 1
  Next zähler
  ReDim Werte(Hilfszähler - 1)
  ReDim Legende_Bezeichner(Hilfszähler - 1)
 
  ' Nachbearbeitete Werte in neues Variablenfeld schieben
  For zähler = LBound(Ein_Werte()) To UBound(Ein_Werte())
    If Ein_Werte(zähler) = 0 Then Exit For
    Werte(zähler) = Ein_Werte(zähler)
    Legende_Bezeichner(zähler) = Ein_Name(zähler)
  Next zähler
  ReDim Filmanzahl(UBound(Werte()))
  For zähler = LBound(Werte()) To UBound(Werte())
    Filmanzahl(zähler) = Werte(zähler)
  Next zähler
 
  ' alle Werte des übergebenen Feldes zusammenrechnen
  For zähler = LBound(Werte()) To UBound(Werte())
    Werte_Gesamt = Werte_Gesamt + Werte(zähler)
  Next zähler
 
  ' Tortenstückgroße berechnen
  For zähler = LBound(Werte()) To UBound(Werte())
    Gesamt_Winkel = Gesamt_Winkel + Werte(zähler)
    Temp = Gesamt_Winkel / Werte_Gesamt * 360
    ' zum Winkel die Startposition dazurechnen
    Temp = Temp + Start_Position
    If Temp > 360 Then Temp = Temp - 360
    ' umrechnen ins Bogenmaß
    Temp = Temp * Pi / 180
    Werte(zähler) = Temp
  Next zähler
 
  ' Jetzt den Kreis / die Ellipse in mehreren Schichten
  ' zeichnen (Scheiben-Effekt)
  Zeichen_Obj.DrawWidth = 1
  Zeichen_Obj.DrawStyle = 0
  For Hilfszähler = Kreis_Mitte_Y + Höhe To Kreis_Mitte_Y Step -Abstand
    Zeichen_Obj.FillStyle = 0
    For zähler = LBound(Werte()) To (UBound(Werte())) - 1
      Zeichen_Obj.FillColor = Kreis_Farben(zähler + 1)
      Zeichen_Obj.ForeColor = Kreis_Farben(zähler + 1)
      Zeichen_Obj.Circle (Kreis_Mitte_X, Hilfszähler), _
      Kreis_Größe, , -Werte(zähler), -Werte(zähler + 1), Ellipse
    Next zähler
 
    ' Erstes Stück malen
    Zeichen_Obj.ForeColor = Kreis_Farben(LBound(Kreis_Farben()))
    Zeichen_Obj.FillColor = Kreis_Farben(LBound(Kreis_Farben()))
    Zeichen_Obj.Circle (Kreis_Mitte_X, Hilfszähler), _
    Kreis_Größe, , -Werte(UBound(Werte)), -Werte(LBound(Werte)), Ellipse
 
    ' Jetzt einen Ring um die Schicht malen
    If Ringe = True Then
      Zeichen_Obj.ForeColor = Farbe_3D
      Zeichen_Obj.FillColor = Farbe_3D
      Zeichen_Obj.FillStyle = 1
      Zeichen_Obj.Circle (Kreis_Mitte_X, Hilfszähler), Kreis_Größe, , , , Ellipse
    End If
  Next Hilfszähler
 
  ' an die Vorgegebene Position die Legende zeichnen
  Zeichen_Obj.DrawWidth = 5
 
  ' Wenn die Legende vom Max nach Min angezeigt werden soll
  If Aufsteigend = False Then
    For zähler = LBound(Legende_Bezeichner()) To UBound(Legende_Bezeichner())
      Zeichen_Obj.CurrentX = Legende_X
      Zeichen_Obj.CurrentY = zähler * 14 + Legende_Y
      Zeichen_Obj.ForeColor = Kreis_Farben(zähler)
      Zeichen_Obj.Line (Zeichen_Obj.CurrentX, Zeichen_Obj.CurrentY)- _
        (Zeichen_Obj.CurrentX + 10, Zeichen_Obj.CurrentY)
      Zeichen_Obj.CurrentY = Zeichen_Obj.CurrentY - 7
      Zeichen_Obj.ForeColor = Legende_Farbe
 
      ' Wenn gewünscht Anzahl in die Legende schreiben sonst nicht
      If Legende_Anzahl_Zeigen = False Then
        Zeichen_Obj.Print "  " & Legende_Bezeichner(zähler)
      End If
      If Legende_Anzahl_Zeigen = True Then
        If Len(CStr(Filmanzahl(zähler))) = 1 Then
          Text_Anzahl = "   " & CStr(Filmanzahl(zähler))
        End If
        If Len(CStr(Filmanzahl(zähler))) = 2 Then
          Text_Anzahl = "  " & CStr(Filmanzahl(zähler))
        End If
        If Len(CStr(Filmanzahl(zähler))) = 3 Then
          Text_Anzahl = " " & CStr(Filmanzahl(zähler))
        End If
        Zeichen_Obj.Print " " & Text_Anzahl & " " & Legende_Bezeichner(zähler)
      End If
    Next zähler
 
  ' Wenn die Legende von Min nach Max angezeigt werden soll
  Else
    For zähler = UBound(Legende_Bezeichner()) To LBound(Legende_Bezeichner()) Step -1
      Zeichen_Obj.CurrentX = Legende_X
      Zeichen_Obj.CurrentY = (UBound(Legende_Bezeichner()) - zähler * 14 + _
      Legende_Y) + UBound(Legende_Bezeichner) * 13
      Zeichen_Obj.ForeColor = Kreis_Farben(zähler)
      Zeichen_Obj.Line (Zeichen_Obj.CurrentX, Zeichen_Obj.CurrentY)- _
        (Zeichen_Obj.CurrentX + 10, Zeichen_Obj.CurrentY)
      Zeichen_Obj.CurrentY = Zeichen_Obj.CurrentY - 7
      Zeichen_Obj.ForeColor = Legende_Farbe
 
      ' Wenn gewünscht Anzahl in die Legende schreiben sonst nicht
      If Legende_Anzahl_Zeigen = False Then
        Zeichen_Obj.Print "  " & Legende_Bezeichner(zähler)
      End If
      If Legende_Anzahl_Zeigen = True Then
        If Len(CStr(Filmanzahl(zähler))) = 1 Then
          Text_Anzahl = "   " & CStr(Filmanzahl(zähler))
        End If
        If Len(CStr(Filmanzahl(zähler))) = 2 Then
          Text_Anzahl = "  " & CStr(Filmanzahl(zähler))
        End If
        If Len(CStr(Filmanzahl(zähler))) = 3 Then
          Text_Anzahl = " " & CStr(Filmanzahl(zähler))
        End If
        Zeichen_Obj.Print " " & Text_Anzahl & " " & Legende_Bezeichner(zähler)
      End If
    Next zähler
  End If
End Sub

Ein kleines Anwendungsbeispiel

Private Sub Form_Load()
  Dim Verbrauch(11) As Integer
  Dim Farben(11) As Long
  Dim Bezeichner(11) As String
 
  ' Eigenschaften des Ausgabeobjekts festlegen
  Me.AutoRedraw = True
  Me.Width = 8655
  Me.Height = 5700
  Me.Print ""
  Me.Print " Bierverbrauch in Flaschen:"
 
  ' Legende
  Bezeichner(0) = "Jan.": Bezeichner(1) = "Feb.": Bezeichner(2) = "März"
  Bezeichner(3) = "Apr.": Bezeichner(4) = "Mai": Bezeichner(5) = "Juni"
  Bezeichner(6) = "Juli": Bezeichner(7) = "Aug.": Bezeichner(8) = "Sep."
  Bezeichner(9) = "Okt.": Bezeichner(10) = "Nov.": Bezeichner(11) = "Dez."
 
  ' Werte
  Verbrauch(0) = 100: Verbrauch(1) = 120: Verbrauch(2) = 90: Verbrauch(3) = 75
  Verbrauch(4) = 120: Verbrauch(5) = 140: Verbrauch(6) = 145: Verbrauch(7) = 160
  Verbrauch(8) = 130: Verbrauch(9) = 100: Verbrauch(10) = 90: Verbrauch(11) = 140
 
  ' Farben
  Farben(0) = vbBlack: Farben(1) = vbBlue: Farben(2) = vbCyan
  Farben(3) = vbGreen: Farben(4) = vbMagenta: Farben(5) = vbRed
  Farben(6) = vbWhite: Farben(7) = vbYellow: Farben(8) = &HC0C0FF
  Farben(9) = &HFFC0C0: Farben(10) = &H80FF&: Farben(11) = &H8000&
 
  ' Tortendiagramm zeichnen
  Torte_Zeichnen Verbrauch(), Farben(), 220, 240, 150, 70, Bezeichner(), _
    480, 20, vbBlack, True, True, 0.4, 80, 2, &H808080, True, Me
End Sub

Dieser Tipp wurde bereits 8.276 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
(einschl. Beispielprojekt!)

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
   

Druckansicht Druckansicht Copyright ©2000-2014 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.

Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel