Sie kennen sicherlich auch diese coolen Diagramme, in denen die Werte dreidimensional, über kleine Berge, die aus einer Ebene ragen, dargestellt werden. Heute präsentieren wir Ihnen genau diese Funktion, um mit einem Aufruf die Werte aus einem Array auf diese Weise darzustellen. 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 Private höhex 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 32.910 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
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. |
vb@rchiv CD Vol.6 Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! Online-Update-Funktion Entwickler-Vollversionen u.v.m. Tipp des Monats März 2024 Dieter Otter UTF-8 Konvertierung von Dateien und Strings VB6 selbst verfügt über keine Funktionen zur UTF-8 Konvertierung von Daten. Mit Hilfe des ADODB.Stream-Objekts lassen sich diese fehlenden Funktionen aber schnell nachrüsten. Neu! sevCoolbar 3.0 Professionelle Toolbars im modernen Design! Mit sevCoolbar erstellen Sie in wenigen Minuten ansprechende und moderne Toolbars und passen diese optimal an das Layout Ihrer Anwendung an (inkl. große Symbolbibliothek) - für VB und MS-Access |
||||||||||||||||
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. |