Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0762: Logarithmische Darstellungen I - halblogarithmische Skala

VB 5/6-Tipp 0762: Logarithmische Darstellungen I - halblogarithmische Skala

 von Klaus Langbein

Schwierigkeitsgrad:

Verwendete API-Aufrufe: keine

Download: Download des Beispielprojektes [4.68 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 PrjLogLin.vbp  ------------
'----- Anfang Formular "frmLogLin" alias frmLogLin.frm  -----
' Steuerelement: Schaltfläche "cmdDraw"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Logarithmische Darstellung der Gauß'schen Glockenkurve
'
' In wissenschaftlichen Anwendungen ist es gelegentlich von Vorteil,
' Kurven auf logarithmischen Skalen darzustellen. Hier wird anhand
' der Gaussschen Glockenkuve gezeigt, wie dies mit VB-Mitteln
' bewerkstelligt werden kann. Die Ausgabe der Kurve erfolgt, wie
' bei Kurven mit linearer Skala. Innerhalb der Skalierungsfunktion
' hier yyc() wird jedoch logarithmiert um die y-Position in Einheiten
' des Ausgabegeräts (Picturebox, Drucker) zu berechnen.
'
' Die Gauß'sche Glockenkurve hat in halblogarithmischer Darstellung
' die Form einer Parabel.
'
' K. Langbein, ActiveVB.de, 2007

'Option Explicit ' Für Warmduscher

Dim xFact As Double
Dim yFact As Double
Dim xOff As Long
Dim yOff As Long

Dim xMax As Double
Dim yMax As Double
Dim xMin As Double
Dim yMin As Double

Dim LowDecY As Long
Dim HighDecY As Long

Dim MarginLeft As Double
Dim MarginRight As Double
Dim MarginTop As Double
Dim MarginBottom As Double

Dim n As Double
Dim x As Double
Dim y As Double




Private Function MiniArrow(Ctrl As Object, _
                           ByVal x1 As Double, _
                           ByVal y1 As Double, _
                           ByVal x2 As Double, _
                           ByVal y2 As Double, _
                           Optional ByVal Arrow$, _
                           Optional CreateNew As Boolean _
                           ) As Long

    ' Zeichnet Linie und Pfeilspitze für Linien mit einem Winkel
    ' von 0, 90, 180, 270° oder Winkeln, die nahe an den angeg. Werten
    ' liegen.
    
    Static xp() As Double
    Static yp() As Double
    Static cnt As Long
    Dim r As Double
    Dim x() As Double
    Dim y() As Double
    Dim dx As Double
    Dim dy As Double
    Dim Alpha As Double
    Dim SinA As Double
    Dim CosA As Double
    Dim sm As Long
    Const Pi = 3.14159265358979
    Dim i As Long
    Dim j As Long
    Dim t$()
    
    sm = Ctrl.ScaleMode
    x1 = Ctrl.ScaleX(x1, sm, 3)
    x2 = Ctrl.ScaleX(x2, sm, 3)
    y1 = Ctrl.ScaleY(y1, sm, 3)
    y2 = Ctrl.ScaleY(y2, sm, 3)
    Ctrl.ScaleMode = 3
    
    dx = x2 - x1
    dy = y2 - y1
    r = Sqr(dx ^ 2 + dy ^ 2)
    Alpha = Atn(dy / (dx + 1E-300))

    If dx < 0 Then
        Alpha = Alpha + Pi
    End If
    If Arrow$ = "" Then
        Arrow$ = "7,3,1,1,2,1,2,2,3,2,4,2,1,3,2,3,3,3,4,3,5,3,6,3,2,4,3,4,4,4,1,5,2,5"
    End If
    
    If cnt = 0 Or CreateNew = True Then
        t() = Split(Arrow$, ",")
        cnt = ((UBound(t) - 1) / 2)
        ReDim xp(cnt)
        ReDim yp(cnt)
        
        For i = 0 To UBound(t()) Step 2
            xp(j) = Val(t(i))
            yp(j) = Val(t(i + 1))
            j = j + 1
        Next i
    End If
    
    dx = x1 + r - xp(0)
    dy = y1 - yp(0)
    
    ReDim x(cnt)
    ReDim y(cnt)
        
    For i = 1 To cnt
        x(i) = dx + xp(i)
        y(i) = dy + yp(i)
    Next i
    
    SinA = Sin(Alpha)
    CosA = Cos(Alpha)
    
    If Alpha <> 0 Then
        For i = 1 To cnt
            dx = x(i) - x1
            dy = y(i) - y1
            x(i) = (x1 + CosA * dx - SinA * dy)
            y(i) = (y1 + SinA * dx + CosA * dy)
        Next i
    End If
    
    Ctrl.Line (x1, y1)-(x2, y2)
    For i = 0 To cnt
        Ctrl.PSet (x(i), y(i))
    Next i
    
    Ctrl.ScaleMode = sm ' Scalemode zurücksetzen
    
End Function

Private Function DrawGauss()

    Dim xStep As Double
    Dim x As Double
    Dim y As Double

    Picture1.ForeColor = vbBlue
    Picture1.DrawWidth = 1
    
    x = xMin
    y = Exp(-x ^ 2)
    Picture1.PSet (xxc(x), yyc(y)) ' Ersten Punkt setzen

    xStep = 10 ^ (LowDecY + 1) ' Schrittweite muß so angepasst werden, dass
                               ' auch bei den niederwertigen Dekaden
                               ' noch genügend Shritte entstehen
    
    For x = xMin To xMax Step xStep

        y = Exp(-x ^ 2)

        If y <> 0 Then
            Picture1.Line -(xxc(x), yyc(y))
        End If
        
    Next x

End Function




Private Function DrawScale()

    Dim Decade As Long
    Dim Grey As Long
    Dim ys As Double
    Dim ye As Double
    Dim k As Long
    Dim c As Long
    Dim Fmt$
    Dim Txt$
    Dim tx$
    Dim th As Single
    Dim tw As Single
    Dim xx As Long
    Dim yy As Long
    Dim xxmin As Long
    Dim xxmax As Long
    Dim yymin As Long
    Dim yymax As Long
    Dim dx As Double
    
    Picture1.Cls
    Set Picture1.Picture = Nothing
    Picture1.DrawWidth = 1
    Picture1.FontName = "Arial"
    Picture1.FontSize = 8
    Picture1.FontBold = False
    th = Picture1.TextHeight("H")
    
    Grey = 220
    Grey = RGB(Grey, Grey, Grey)
    xxmin = xxc(xMin)
    xxmax = xxc(xMax)
    yymin = yyc(yMin)
    yymax = yyc(yMax)
    
    ' Rahmen
    Picture1.Line (xxmin, yymax)-(xxmax, yymin), Grey, B
    
    ' Vertikale Gitterlinien
    For x = xMin To xMax Step (xMax - xMin) / 26
        xx = xxc(x)
        Picture1.Line (xx, yymax)-(xx, yymin), Grey
    Next x
    
    ' Horizontale Gitterlinien (logarithmisch in Y)
    For Decade = LowDecY To HighDecY
    
        ys = 10 ^ Decade
        ye = 10 ^ (Decade + 1)
        
        For y = ys + k * ys To ye + (ys / 1000) Step ys
        
            yy = yyc(y)
            
            Picture1.Line (xxmin, yy)-(xxmax, yy), Grey
            
            Fmt$ = "0"
            If Decade < 0 Then
                Fmt$ = Fmt$ & "." & String$(Abs(Decade), "0")
            End If
            
            Txt = Format$(y, Fmt$)
            tx = Replace(Txt, "0", "")
            tx = Replace(tx, ".", "")
            tx = Replace(tx, ",", "")
            
            Select Case tx
            Case 1, 2, 3, 4, 6, 8
                tw = Picture1.TextWidth(Txt)
                Picture1.CurrentX = MarginLeft - 50 - tw
                Picture1.CurrentY = yy - th / 2
                Picture1.ForeColor = 0
                Picture1.Print Txt
            End Select
            
        Next y
        k = 1  ' bewirkt, dass außer beim 1. Durchlauf
               ' bei y=(ys+ys) angefangen wird.
        
    Next Decade
    
    Picture1.ForeColor = 0
    Picture1.DrawWidth = 1
    
    ' Schwarze Linien (horizontal) für volle Dekaden
    For Decade = LowDecY To HighDecY

        yy = yyc(10 ^ Decade)
        Picture1.Line (xxmin, yy)-(xxmax, yy)

    Next Decade
    
    ' Vertikale Mittellinie bei x=0
    Picture1.Line (xxc(0), yymax)-(xxc(0), yymin)
    
    Picture1.DrawWidth = 1 ' Hier evtl. DrawWidth = 2 setzen
    Picture1.Line (xxmin, yymax)-(xxmax, yymin), , B
    
    ' Achsbeschriftung x
    yy = yymin + 20
    Picture1.CurrentY = yy
    For x = -2.4 To xMax Step 0.4
    
        x = Round(x, 2) ' wird aufgrund von Rechenfehlern benötigt
        xx = xxc(x)
        Txt$ = Format$(x, "0.0")
        tw = Picture1.TextWidth(Txt$) / 2
    
        If x < 0 Then
            dx = 90
        Else
            dx = 45
        End If
        
        Picture1.CurrentX = xx - tw / 2 - dx
        Picture1.Print Txt$;
    Next x
    
    ' Legende X-Achse
    Txt$ = "x"
    Picture1.FontSize = 10
    Picture1.FontBold = True
    tw = Picture1.TextWidth(Txt$)
    
    Picture1.CurrentX = xxmin + (xxmax - xxmin) / 2 - tw / 2
    Picture1.CurrentY = yymin + 250
    Picture1.Print Txt$;
    th = Picture1.TextHeight(Txt$)
    xx = Picture1.CurrentX + 100
    yy = Picture1.CurrentY + th / 2
    
    Call MiniArrow(Picture1, xx, yy, xx + 500, yy)
    
    ' Legende Y-Achse
    Txt$ = "y"
    Picture1.CurrentX = MarginLeft - 800
    Picture1.CurrentY = Picture1.ScaleHeight / 2
    Picture1.Print Txt$;
    tw = Picture1.TextWidth(Txt$)
    xx = MarginLeft - 800 + tw / 2
    yy = Picture1.CurrentY - 50
    
    Call MiniArrow(Picture1, xx, yy, xx, yy - 500)
     
    ' Überschrift
    Picture1.FontSize = 11
    Picture1.FontBold = False
    Txt$ = "Gauß'sche Glockenkurve in halblogarithmischer Darstellung"
    tw = Picture1.TextWidth(Txt$)
    Picture1.CurrentY = 300
    Picture1.CurrentX = MarginLeft + (xxmax - xxmin) / 2 - tw / 2
    Picture1.Print Txt$
    
    ' Beschriftung in Grafik
    Picture1.FontSize = 12
    Picture1.FontBold = True
    Txt$ = "y = e"
    Picture1.CurrentY = yyc(0.27)
    Picture1.CurrentX = xxc(-1.95)
    Picture1.Print Txt$;
    
    Picture1.FontSize = 10
    Picture1.FontBold = True
    Txt$ = "-x"
    Picture1.CurrentY = yyc(0.3)
    Picture1.Print Txt$;
    
    Picture1.FontSize = 6
    Picture1.FontBold = True
    Txt$ = "2"
    Picture1.CurrentY = yyc(0.3)
    Picture1.Print Txt$;
    
End Function

Sub Fact()

    Dim w As Double
    Dim h As Double
    
    w = (Picture1.ScaleWidth - MarginLeft - MarginRight)
    h = (Picture1.ScaleHeight - MarginTop - MarginBottom)
    xFact = w / (xMax - xMin) ' Umrechnungsfaktoren
    yFact = h / (yMax - yMin)
    '
    xOff = MarginLeft + Abs(xMin) * xFact
    yOff = MarginTop + yMax * yFact
    yFact = -yFact
    
    yMin = 10 ^ yMin
    yMax = 10 ^ yMax
    
End Sub

Function xxc(ByVal x As Double) As Long

    xxc = xOff + x * xFact

End Function
Function yyc(ByVal y As Double) As Long
    
    ' Die Logarithmierung wird hier in die Skalierungsfunktion
    ' ausgegliedert. So braucht man sich weder beim Zeichnen des
    ' Gitters, noch beim Zeichnen der Kurve um die Logarithmierung
    ' zu kümmern.
    
    yyc = yOff + Log(y) / Log(10) * yFact

End Function

Private Sub cmdDraw_Click()

     ' Ränder inderhalb des Zeichenbereichs
    MarginLeft = 1000
    MarginRight = 300
    MarginTop = 800
    MarginBottom = 600
    
    ' Minimal- und Maximalwerte des Diagramms (unabh. von der Ausgabe)
        
    LowDecY = -3  ' Dekadennummern: -1 ist die Dekade,
    HighDecY = -1 ' die bei 0.1 anfängt und bei 1 aufhört.
    
    yMin = Log(10 ^ LowDecY) / Log(10)
    yMax = Log(10 ^ (HighDecY + 1)) / Log(10)
    
    xMin = -2.6
    xMax = -xMin

    Call Fact
    Call DrawScale
    Call DrawGauss

End Sub

Private Sub Form_Load()

    Picture1.AutoRedraw = True
    Picture1.Backcolor = vbWhite
    Picture1.Width = 7700
    Picture1.Height = 6500
    cmdDraw.Caption = "Draw"
    
End Sub


Private Sub Form_Resize()

    Dim w As Double
    Dim h As Double
    
    With Picture1
        w = ScaleWidth - 2 * .Left
        h = ScaleHeight - .Top - .Left
        .Move .Left, .Top, w, h
    End With
    Call cmdDraw_Click
    
End Sub

'------ Ende Formular "frmLogLin" alias frmLogLin.frm  ------
'------------- Ende Projektdatei PrjLogLin.vbp  -------------