vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
SEPA-Dateien erstellen inkl. IBAN-, BLZ-/Kontonummernprüfung  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2019
 
zurück
Rubrik: Grafik und Font · Sonstiges   |   VB-Versionen: VB4, VB5, VB620.09.04
3D-Diagramm erstellen

Mit diesem Code erstellen Sie schnell und einfach ein ansprechendes 3D-Diagramm

Autor:   Tobias TangemannBewertung:     [ Jetzt bewerten ]Views:  30.721 
ohne HomepageSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8, Win10 Beispielprojekt auf CD 

Sie kennen sicherlich auch diese coolen Diagramme, in denen die Werte dreidimensional, über kleine Berge, die aus einer Ebene ragen, dargestellt werden.

3D-Diagramm

Heute präsentieren wir Ihnen genau diese Funktion, um mit einem Aufruf die Werte aus einem Array auf diese Weise darzustellen.
Fügen Sie hierzu nachfolgendenn Code in ein Modul ein.

Option Explicit
 
' Benötigte API-Deklarationen
Private Declare Function Polygon Lib "gdi32" ( _
  ByVal hDC As Long, _
  lpPoint As POINTAPI, _
  ByVal nCount As Long) As Long
 
Private Type POINTAPI
  x As Long
  y As Long
End Type
 
' Konstante PI
Private Const Pi As Double = 3.14159265358979
 
' Private Variablen
Private reihen As Long
Private spalten As Long
 
Private kastenhöhe As Long
Private kastenbreite As Long
 
Private startpunktX As Long
Private startpunktY As Long
 
Private winkel As Double
 
Private breitex As Long
Private breitey As Long
 
Privatehex As Long
Private höhey As Long
' Größe berechnen
Public Sub ErrechneGrößen()
  breitex = Round(Cos(GradInBogen(winkel)) * kastenbreite, 0)
  breitey = Round(Sin(GradInBogen(winkel)) * kastenbreite, 0)
 
  höhex = Round(Cos(GradInBogen(winkel)) * kastenhöhe, 0)
  höhey = Round(Sin(GradInBogen(winkel)) * kastenhöhe, 0)
End Sub
' Größe festlegen
Public Sub setzegrößen(ByRef startx As Long, ByRef starty As Long)
  reihen = 20
  spalten = 10
  kastenhöhe = 20
  kastenbreite = 20
  winkel = 20
  startpunktX = startx
  startpunktY = starty
End Sub
' 3D-Diagramm zeichnen
Public Sub ZeichneDiagramm(ByRef picBox As PictureBox, _
  ByRef lngStartX As Long, ByRef lngStartY As Long, _
  ByRef lngKBreite As Long, ByRef lngKHöhe As Long, _
  ByRef lngReihen As Long, ByRef lngSpalten As Long, _
  ByRef BackColor As Long, ByRef LineColor As Long, _
  ByRef lngWerte() As Long)
 
  Dim lngBreiteX As Long, lngBreiteY As Long
  Dim lngHöheX As Long, lngHöheY As Long
  Dim dblWinkel As Double
  Dim mylngStartX As Long
  Dim x As Long, y As Long
  Dim i As Long, j As Long
  Dim punktx0 As Long, punkty0 As Long
  Dim punktx1 As Long, punkty1 As Long
  Dim punktx2 As Long, punkty2 As Long
  Dim punktx3 As Long, punkty3 As Long
  Dim punkte() As POINTAPI
 
  With picBox
    .AutoRedraw = True
    .ScaleMode = 3
    .FillColor = BackColor
    .FillStyle = 0
    .ForeColor = LineColor
  End With
 
  dblWinkel = 20
 
  lngBreiteX = Round(Cos(GradInBogen(dblWinkel)) * lngKBreite, 0)
  lngBreiteY = Round(Sin(GradInBogen(dblWinkel)) * lngKBreite, 0)
 
  lngHöheX = Round(Cos(GradInBogen(dblWinkel)) * lngKHöhe, 0)
  lngHöheY = Round(Sin(GradInBogen(dblWinkel)) * lngKHöhe, 0)
 
  mylngStartX = lngStartX + (lngBreiteX * (lngReihen - 1))
 
  For i = 0 To lngSpalten - 1
    For j = 1 To lngReihen - 1
 
      punktx0 = mylngStartX - (lngBreiteX * j) + (lngHöheX * i)
      punkty0 = lngStartY + (lngBreiteY * j) + (lngHöheY * i)
 
      punktx1 = punktx0
      punkty1 = punkty0 - lngWerte(j, i)
 
      punktx2 = punktx0 - lngHöheX
      punkty2 = punkty0 - lngHöheY
 
      If i <> 0 Then
        punkty2 = punkty2 - lngWerte(j, i - 1)
      End If
 
      If j <> lngReihen - 1 Then
        punktx3 = punktx0 - lngBreiteX
        punkty3 = punkty0 + lngBreiteY - lngWerte(j + 1, i)
      End If
 
      If i <> 0 Then
        ReDim punkte(3)
        punkte(0).x = punktx1
        punkte(0).y = punkty1
        punkte(1).x = punktx2
        punkte(1).y = punkty2
        punkte(2).x = punktx0 - lngHöheX + lngBreiteX
        punkte(2).y = punkty0 - lngHöheY - lngBreiteY
 
        If j <> 0 And i <> 0 Then
          punkte(2).y = punkte(2).y - lngWerte(j - 1, i - 1)
        End If
 
        punkte(3).x = punktx0 + lngBreiteX
        punkte(3).y = punkty0 - lngBreiteY
 
        If j <> 0 Then
          punkte(3).y = punkte(3).y - lngWerte(j - 1, i)
        End If
 
        Polygon picBox.hDC, punkte(0), 4
      End If
    Next
  Next
End Sub
' Zur Umrechnung eines Winkels vom Bogen- in das Gradmaß
Private Function BogenInGrad(ByRef bogen As Double) As Double
  BogenInGrad = bogen / (Pi / 180)
End Function
' Zur Umrechnung eines Winkels von Grad- in das Bogenmaß
Private Function GradInBogen(ByRef grad As Double) As Double
  GradInBogen = grad * (Pi / 180)
End Function
' Wert runden
Private Function Round(ByVal nummer As String, _
  Optional anzahl As Byte)
 
  Dim n As Long
  Dim n2 As Long
  Dim tmp As Variant
 
  ' Ist Nummer eine Zahl?
  If Not (IsNumeric(nummer)) Then
    Round = 0: Exit Function
  End If
 
  ' Ist Anzahl eine Zahl?
  If Not (IsNumeric(anzahl)) Then
    Round = 0: Exit Function
  End If
 
  ' Wenn "." (Punkt) dann n=46
  If (InStr(1, nummer, ".") > 0) Then
    tmp = Split(nummer, ".")
    n = 46
 
  ' Wenn "," (Komma) dann n=44
  ElseIf (InStr(1, nummer, ",") > 0) Then
    tmp = Split(nummer, ",")
    n = 44
  Else
    Round = nummer: Exit Function
  End If
 
  If Len(tmp(1)) <= anzahl Then
    Round = nummer: Exit Function
  End If
 
  ' Wenn Anzahl = 0, Zahl vor dem Komma prüfen
  If (anzahl = 0) Then
    If Left$(tmp(1), 1) < 5 Then
      ' Wenn Zahl vor dem Komma kleiner 5,
      ' nicht runden!
      Round = tmp(0)
    Else
       ' Wenn Zahl größer 5, um eins erhöhen
      Round = tmp(0) + 1
    End If
    Exit Function
  End If
 
  ' Stelle (Anzahl+1) nach dem Komma abfragen
  n2 = Mid$(tmp(1), anzahl + 1, 1)
  If (n2 > 4) Then
    Round = tmp(0) & Chr(n) & (Mid$(tmp(1), 1, anzahl) + 1)
  ElseIf (n2 < 5) Then
    Round = tmp(0) & Chr(n) & Mid$(tmp(1), 1, anzahl)
  End If
End Function

Platzieren Sie auf die Form ein PictureBox-Control in der Größe Width=8175 und fügen nachfolgenden Code in das Form_Load Ereignis ein:/p>

Private Sub Form_Load()
  Dim a() As Long
 
  ' ein paar Testwerte
  ReDim a(19, 9)
  a(1, 1) = 10
  a(1, 5) = 20
  a(2, 5) = 20
  a(1, 6) = 20
  a(2, 6) = 20
  a(10, 1) = 30
  a(11, 1) = 30
  a(10, 8) = 40
  a(14, 7) = 80
 
  ' Diagramm zeichnen
  ZeichneDiagramm Picture1, 10, 10, 20, 20, 20, 10, vbMagenta, vbBlack, a
End Sub

Dieser Tipp wurde bereits 30.721 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-2019 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