Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0781: Diagramme mit eigener Skalierung

 von 

Beschreibung 

Kurven zu zeichnen ist mit den Standardfunktionen Line und Pset recht einfach. Es müssen jedoch meist Skalierungsfaktoren und eine Ortsverschiebung, also eine Koordinatentransformation vorgenommen werden. VB bietet hierfür die Scale-Funktion, mit deren Hilfe benutzerdefinierte Skalen eingestellt werden können. Übernimmt man die Skalierung jedoch selbst in eigenen Funktionen hat man einen größeren Gestaltungsspielraum und man ist Herr der Lage. Gerechnet wird mit x und y in den vorgegebenen Grenzen und vor der Ausgabe wird die Transformation in 2 kurzen Funktionen durchgeführt. Vorteile sind, dass man ohne Scalemode zu wechseln, die Positionierung der Schrift im eingestellten Scalemode (z.B. Pixel) vornehmen kann, während die Kurve in weltlichen Einheiten bearbeitet werden kann. Des Weiteren hat man die Möglichkeit die Ausgabe schnell auf API-Methoden umzustellen.

Benötigt man neben dem Diagramm Ränder für eine Beschriftung, so muß dies bei Einstellung der Faktoren berücksichtigt werden. Im vorliegenden Beispiel wird die Skalierung so berechnet, dass feste Ränder in Einheiten von Pixeln oder Twipps unabhängig von der Größe und Skalierung des Diagramms vorgegeben werden können. Zusätzlich kann das Diagramm auf dem Ausgabegerät (Drucker) oder auf einer Picturebox oder Form beliebig positioniert werden.

Schwierigkeitsgrad:

Schwierigkeitsgrad 1

Verwendete API-Aufrufe:

keine

Download:

Download des Beispielprojektes [6,87 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'----------- Anfang Projektdatei PrjDiagram2.vbp  -----------
'--- Anfang Formular "frmDiagram2" alias frmDiagram2.frm  ---
' Steuerelement: Schaltfläche "cmdSimple"
' Steuerelement: Schaltfläche "cmdDraw"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
'
' Kurven zu zeichnen ist mit den Standardfunktionen Line und Pset
' recht einfach. Es müssen jedoch meist Skalierungsfaktoren
' und eine Ortsverschiebung, also eine Koordinatentransformation
' vorgenommen werden. VB bietet hierfür die Scale-Funktion,
' mit deren Hilfe benutzerdefinierte Skalen eingestellt werden können.
' Übernimmt man die Skalierung jedoch selbst in eigenen Funktionen
' hat man einen größeren Gestaltungsspielraum und man ist Herr der Lage.
' Gerechnet wird mit x und y in den vorgegebenen Grenzen und vor der
' Ausgabe wird die Transformation in 2 kurzen Funktionen durchgeführt.
' Vorteile sind, dass man ohne Scalemode zu wechseln, die Positionierung
' der Schrift im eingestellten Scalemode (z.B. Pixel) vornehmen kann,
' während die Kurve in weltlichen Einheiten bearbeitet werden kann.
' Des Weiteren hat man die Möglichkeit die Ausgabe schnell auf
' API-Methoden umzustellen.
'
' Benötigt man neben dem Diagramm Ränder für eine Beschriftung, so
' muß dies bei Einstellung der Faktoren berücksichtigt werden. Im
' vorliegenden Beispiel wird die Skalierung so berechnet, dass feste
' Ränder in Einheiten von Pixeln oder Twipps unabhängig von der Größe
' und Skalierung des Diagramms vorgegeben werden können. Zusätzlich kann
' Das Diagramm auf dem Ausgabegerät (Drucker) oder auf einer Picturebox
' oder Form beliebig positioniert werden.
'

' Option Explicit      ' Nur für Nerds
Dim xMax As Double     ' Maximalwerte, die im Diagramm möglich sein sollen
Dim xMin As Double
Dim yMax As Double
Dim yMin As Double
'
Dim sxMax As Double    ' Maximalwerte inklusive Ränder
Dim sxMin As Double
Dim syMax As Double
Dim syMin As Double
'
Dim MarginLeft As Long ' Ränder in Bildschirmeinheiten (Pixel, Twipps)
Dim MarginTop As Long
Dim MarginRight As Long
Dim MarginBottom As Long
'
Dim xFact As Double
Dim yFact As Double
Dim xOff As Double
Dim yOff As Double


Private Function Arrow90(ByVal Pic As Object, _
                         ByVal x1 As Double, _
                         ByVal y1 As Double, _
                         ByVal x2 As Double, _
                         ByVal y2 As Double, _
                         ByVal L As Double, _
                         ByVal Angle As Long) As Long
                       
    Dim fs As Long
    fs = Pic.FillStyle
    Pic.FillStyle = 0
    Pic.Line (x1, y1)-(x2, y2)
    Select Case Angle
    Case 0
        Pic.Circle (x2, y2), L, , -2.836, -3.436
    Case 90
        Pic.Circle (x2, y2), L, , -4.398, -4.998
    Case 180
        Pic.Circle (x2, y2), L, , -5.979, -0.296
    Case 270
        Pic.Circle (x2, y2), L, , -1.275, -1.875
    End Select
    Pic.FillStyle = fs
    
    
End Function



Function DrawBoundary(Obj As Object, _
                      ByVal Left As Double, _
                      ByVal Top As Double, _
                      ByVal Width As Double, _
                      ByVal Height As Double, _
                      ByVal Grey As Long) As Long
                      
    Obj.ForeColor = RGB(Grey, Grey, Grey)
    Obj.Line (Left, Top)-(Left + Width, Top + Height), , B
                       
              
End Function

Function DrawGridY(Obj As Object, ByVal yStep As Double) As Long

    Dim Grey As Long
    Dim yStart As Double
    Dim xxMin As Long
    Dim yyMin As Long
    Dim xxMax As Long
    Dim yy As Long
    Dim y As Double
    
    Grey = 220
    Obj.ForeColor = RGB(Grey, Grey, Grey)
    yStep = Abs(yStep)
    
    If yStep = 0 Then
        Exit Function
    End If
    
    ' Sonderbehandlung für den Fall, dass die Kurve nicht bei y = 0 anfängt
    If Sgn(yMin) = 1 And Sgn(yMax) = 1 Then
        yStart = yMin
    Else
        yStart = 0
    End If
    
    ' Die Gitterlinien werden jeweils von der Achse nach außen gezeichnet
    ' für den Fall, dass die letzte Linie nicht am Maximalwert liegt.
    
    ' Ausgabe der horizontalen Gitterlinien
    xxMin = xxc(xMin)
    xxMax = xxc(xMax)
    For y = yStart To (yMax) Step yStep
        yy = yyc(y)
        Obj.Line (xxMin, yy)-(xxMax, yy)
    Next y
    
    ' Sonderbehandlung wenn ymax und ymin negativ sind
    If Sgn(yMin) = -1 And Sgn(yMax) = -1 Then
        yStart = yMax
    Else
        yStart = 0
    End If
   
    For y = yStart To (yMin) Step -yStep
        yy = yyc(y)
        Obj.Line (xxMin, yy)-(xxMax, yy)
    Next y


End Function
Function DrawGridX(Obj As Object, ByVal xStep As Double) As Long

    Dim Grey As Long
    Dim xStart As Double
    Dim yyMax As Long
    Dim yyMin As Long
    Dim x As Double
    Dim xx As Long
    
    Grey = 220
    Obj.ForeColor = RGB(Grey, Grey, Grey)
    xStep = Abs(xStep)
    
    If xStep = 0 Then
        Exit Function
    End If
    
    ' Sonderbehandlung für den Fall, dass die Kurve nicht bei x = 0 anfängt
    If Sgn(xMin) = 1 And Sgn(xMax) = 1 Then
        xStart = xMin
    Else
        xStart = 0
    End If
    
    ' Wir zeichnen das Gitter von der Achse nach außen für den Fall
    ' dass die letzte Linie nicht auf dem Maximalwert liegt
    yyMax = yyc(yMax)
    yyMin = yyc(yMin)
    For x = xStart To (xMax) Step xStep
        xx = xxc(x)
        Obj.Line (xx, yyMax)-(xx, yyMin)
    Next x
    
    ' Sonderbehandlung wenn xmax und xmin negativ sind
    If Sgn(xMin) = -1 And Sgn(xMax) = -1 Then
        xStart = xMax
    Else
        xStart = 0
    End If

    For x = xStart To (xMin) Step -xStep
        xx = xxc(x)
        Obj.Line (xx, yyMax)-(xx, yyMin)
    Next x

End Function

Function DrawAxis(ByVal DrawFrame As Boolean) As Long
    
    Dim Grey As Long
    Dim xx1 As Long
    Dim xx2 As Long
    Dim yy1 As Long
    Dim yy2 As Long
    
    Grey = 120
    Picture1.ForeColor = RGB(Grey, Grey, Grey)
    
    ' Achsen und Rahmen zeichen
    xx1 = xxc(xMin)
    xx2 = xxc(xMax)
    yy1 = yyc(yMin)
    yy2 = yyc(yMax)
    Picture1.Line (xx1, yOff)-(xx2, yOff)
    Picture1.Line (xOff, yy1)-(xOff, yy2)
    
    If DrawFrame = True Then
        Picture1.ForeColor = 0
        Picture1.Line (xx1, yy1)-(xx2, yy2), , B
    End If

End Function

Function Fact(ByVal Left As Double, ByVal Top As Double, _
              ByVal Width As Double, ByVal Height As Double) As Long

    ' Die Variablen xMax, yMax, Margin etc werden nicht an die
    ' Funktion Fact übergeben, weil sie Formweit benötigt werden
    ' Umrechnungsfaktoren bestimmen
    
    xFact = (Width - MarginLeft - MarginRight) / (xMax - xMin)
    yFact = (Height - MarginTop - MarginBottom) / (yMax - yMin)
    
    xOff = Left + MarginLeft + Abs(xMin) * xFact
    yOff = Top + MarginTop + Abs(yMax) * yFact
    yFact = -yFact ' Dies tun wir um die Skala umzukehren
    
End Function

Function Legend(ByVal LegendX$, ByVal LegendY$, ByVal Title$) As Long

    Dim Text$
    Dim cnt As Long
    Dim tw As Double
    Dim th As Double
    Dim x As Double
    Dim y As Double
    
    Picture1.ForeColor = 0
    Picture1.FontName = "Arial"
    Picture1.FontSize = 12
    Picture1.FontBold = False
    Text$ = Title
    tw = Picture1.TextWidth(Text)
    '
    cnt = 0
    Do
        If tw > (xMax - xMin) * xFact Then
            Picture1.FontSize = Picture1.FontSize - 0.5
            tw = Picture1.TextWidth(Text)
            cnt = cnt + 1
        Else
            Exit Do
        End If
    Loop Until Picture1.FontSize < 3 Or cnt > 20
    
    th = Picture1.TextHeight(Text)
    Picture1.CurrentX = xxc(xMin + (xMax - xMin) / 2) - tw / 2
    Picture1.CurrentY = yyc(yMax) - th - 5
    Picture1.Print Text$
'
    Picture1.FontName = "Arial"
    Picture1.FontSize = 11
    Picture1.FontBold = True
    Text$ = LegendX$
    tw = Picture1.TextWidth(Text)
    Picture1.CurrentX = xxc(xMin + (xMax - xMin) / 2) - tw / 2
    Picture1.CurrentY = yyc(yMin) + 5
    Picture1.Print Text$;
    x = Picture1.CurrentX + 5
    y = yyc(yMin) + 15
    Arrow90 Picture1, x, y, x + 30, y, 6, 0
    
    Picture1.FontName = "Arial"
    Picture1.FontSize = 11
    Picture1.FontBold = True
    Text$ = LegendY$
    tw = Picture1.TextWidth(Text)
    Picture1.CurrentX = xxc(xMin) - 20
    Picture1.CurrentY = yyc(0) - 10
    Picture1.Print Text$
    
    x = xxc(xMin) - 20 + tw / 2
    y = yyc(0) - 10
    Arrow90 Picture1, x, y, x, y - 30, 6, 90

End Function


'Meßlatte:
'2345678901234567890123456789012345678901234567890123456789012345678901234567890
Function Plot(Obj As Object) As Long

    Dim xStep As Double
    Dim n As Long
    Dim x As Double
    Dim y As Double
    Dim i As Long
    Dim j As Long
    Dim a As Double
    Dim b As Double
    Dim Phi As Double
    Dim Pi As Double
    
    Dim DiagLeft As Long
    Dim DiagTop As Long
    Dim DiagWidth As Long
    Dim DiagHeight As Long
    
    Obj.ScaleMode = 3
    
    ' Festlegen der Position und Größe des gesamten Diagramms auf dem
    ' Ausgabegerät (z.B. Picturbox). Einheiten sind Pixel oder die aktuellen
    ' Einstellungen des DC. Das Diagramm kann so z.B. auf einem
    ' Din A4-Blatt positioniert werden. Falls das Diagramm sich auf die
    ' Grenzen der Picturebox beziehen soll, werden DiagLeft und DiagTop
    ' = 0 gesetzt, während DiagWidh und DiagHeight auf ScaleWidth und
    ' Scaleheight gestellt werden.
    DiagLeft = 10
    DiagTop = 10
    DiagWidth = Obj.ScaleWidth - DiagLeft - 10
    DiagHeight = Obj.ScaleHeight - DiagTop - 10
    
    
    ' Festlegen der Ränder innerhalb des Diagramms. Einheiten sind
    ' ebenfalls noch die voreingestellten Einheiten (Scalemode) des Objekts.
    MarginLeft = 40
    MarginTop = 40
    MarginRight = 10
    MarginBottom = 30
    
    ' Festlegen der Maximalwerte. Einheiten sind hier die geräteunabhängigen
    ' Einheiten des Diagramms (z.B. m, km, kg, Anzahl, usw.).
    xMax = 2.4
    xMin = -2.4
    yMax = 1.2
    yMin = -1.2

    ' Faktoren und Offsets berechnen
    Call Fact(DiagLeft, DiagTop, DiagWidth, DiagHeight)

    ' Zeichnung vorbereiten
    Obj.Cls
    
    ' Zunächs die Grenzen des Diagramms einzeichnen. Dies dient nur
    ' zur Kontrolle und kann später weggelassen werden.
    Call DrawBoundary(Obj, DiagLeft, DiagTop, DiagWidth, DiagHeight, 200)
    
    ' Gitter, Achsen und Rahmen der Zeichenfläche ausgeben
    Call DrawGridY(Obj, yMax / 6)
    Call DrawGridX(Obj, xMax / 6)
    Call DrawAxis(True)
       
    ' Kurve vorbereiten
    Obj.ForeColor = vbBlue
    n = 1000                    ' Anzahl der Punkte festlegen
    'xStep = (xMax - xMin) / n   ' Schrittweite berechnen
    
    a = 1
    b = 1 ' auchmal 4,5,6,8,15,32,33 einsetzen
    Pi = 4 * Atn(1)
    For Phi = 0 To 2 * Pi Step (2 * Pi / n)

        x = (a + a * Cos(8 * Phi) ^ 2) * Sin(b * Phi)
        y = a * Cos(8 * Phi) * Cos(b * Phi)
        If cnt = 0 Then
            Obj.PSet (xxc(x), yyc(y))
        Else
            Obj.Line -(xxc(x), yyc(y))
        End If
        cnt = cnt + 1
        
    Next Phi
    
    Call Legend("x (mm)", "y", "Die Bananengleichung - schwer zu verstehen, was?")
    
End Function

Function xxc(ByVal x As Double) As Long

    xxc = xOff + xFact * x

End Function

Function yyc(ByVal y As Double) As Long

    yyc = yOff + yFact * y

End Function
Private Sub cmdDraw_Click()
    Call Plot(Picture1)
End Sub


Private Sub cmdSimple_Click()

    Unload Me
    frmSimple2.Show

End Sub

Private Sub Form_Load()

    cmdDraw.Move 90, 60
    cmdSimple.Move cmdDraw.Left + cmdDraw.Width, 60
    cmdDraw.Caption = "Draw"
    cmdSimple.Caption = "Simple"
    
    Picture1.AutoRedraw = True
    Picture1.BackColor = vbWhite
    Picture1.ScaleMode = 3
    Picture1.Move 90, 450
    
End Sub

Private Sub Form_Resize()

    With Picture1
        .Move .Left, .Top, ScaleWidth - 2 * .Left, ScaleHeight - .Top - .Left
    End With
    Call Plot(Picture1)
    
End Sub


'---- Ende Formular "frmDiagram2" alias frmDiagram2.frm  ----
'---- Anfang Formular "frmSimple2" alias frmSimple2.frm  ----
' Steuerelement: Schaltfläche "cmdDraw"
' Steuerelement: Schaltfläche "cmdMore"
' Steuerelement: Bildfeld-Steuerelement "Picture1"

Function SimplePlot(Pic As Object) As Long

    ' In dieser Funktion wurde die Methode auf ein Minimum reduziert.
    ' Sie zeigt, welche Schritte mindestens benötigt werden, um eine
    ' Kurve und Achsen zu zeichnen. Die Funktion ist selbstkonsistent
    ' und kann einfach per Cut/Paste in andere Projekte übernommen werden.
    
    Dim xMax As Double
    Dim xMin As Double
    Dim yMax As Double
    Dim yMin As Double
    '
    Dim MarginLeft As Long ' Ränder in Bildschirmeinheiten (Pixel, Twipps)
    Dim MarginTop As Long
    Dim MarginRight As Long
    Dim MarginBottom As Long
    '
    Dim xFact As Double
    Dim yFact As Double
    Dim xOff As Double
    Dim yOff As Double
    Dim x As Double
    Dim y As Double
    '
    Dim xStep As Double
    Dim n As Long
    Dim Grey As Long
    Dim sm As Long
    
    sm = Pic.ScaleMode ' Scalemode zwischenspeichern
    Picture1.ScaleMode = 3
    
    ' Festlegen der Ränder in den aktuellen Einheiten. Es können entweder
    ' feste Werte, z.B. 40 Pixel oder ein Prozentsatz der ScaleWidth oder
    ' ScaleHeight angegeben werden
    MarginLeft = 40    ' Oder Pic.ScaleWidth * 0.1
    MarginTop = 40     ' Oder Pic.ScaleHeight * 0.1
    MarginRight = 20
    MarginBottom = 30
    
    ' Festlegen der Maximalwerte
    xMax = 5
    xMin = -5
    yMax = 1.2
    yMin = -1.2
    '
    xFact = (Picture1.ScaleWidth - MarginLeft - MarginRight) / (xMax - xMin)
    yFact = (Picture1.ScaleHeight - MarginTop - MarginBottom) / (yMax - yMin)
    yFact = -yFact ' Dies tun wir um die Skala umzukehren
    xOff = MarginLeft + Abs(xMin) * xFact
    yOff = MarginTop - Abs(yMax) * yFact
    
    Pic.Cls
    
    ' Achsen und Rahmen zeichen
    Grey = 120
    Pic.ForeColor = RGB(Grey, Grey, Grey)
    Pic.Line (xOff + xFact * xMin, yOff)-(xOff + xFact * xMax, yOff)
    Pic.Line (xOff, yOff + yFact * yMax)-(xOff, yOff + yFact * yMin)
    Pic.ForeColor = 0
    Pic.Line (xOff + xFact * xMin, yOff + yFact * yMax)- _
             (xOff + xFact * xMax, yOff + yFact * yMin), , B
       
    ' Kurve vorbereiten
    n = 1000                     ' Anzahl der Punkte
    xStep = (xMax - xMin) / n    ' Schrittweite berechnen
    
    Pic.ForeColor = vbBlue
    x = xMin
    y = 0
    Pic.PSet (xOff + xFact * x, yOff + yFact * y) ' Den 1. Punkt setzen
    
    ' Jetzt die eigentliche Kurve zeichnen
    For x = xMin To xMax Step xStep
        y = 0
        For i = 1 To 10
            y = y + Sin(i * x ^ 2)
        Next i
        y = y / 10
        Pic.Line -(xOff + xFact * x, yOff + yFact * y)
    Next x
    
    Pic.ScaleMode = sm

End Function


Private Sub cmdDraw_Click()

    SimplePlot Picture1

End Sub


Private Sub cmdMore_Click()

    Unload Me
    frmDiagram2.Show
    
End Sub


Private Sub Form_Load()

    cmdDraw.Move 90, 60
    cmdMore.Move cmdDraw.Left + cmdDraw.Width, 60
    cmdDraw.Caption = "Draw"
    cmdMore.Caption = "Advanced"
    
    Picture1.AutoRedraw = True
    Picture1.BackColor = vbWhite
    Picture1.ScaleMode = 3
    Picture1.Move 90, 450

End Sub

Private Sub Form_Resize()

    With Picture1
        .Move .Left, .Top, ScaleWidth - 2 * .Left, ScaleHeight - .Top - .Left
    End With
    Call SimplePlot(Picture1)
    
End Sub
'----- Ende Formular "frmSimple2" alias frmSimple2.frm  -----
'------------ Ende Projektdatei PrjDiagram2.vbp  ------------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.