Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0761: Logarithmische Darstellungen II - doppelogarithmische Skala

VB 5/6-Tipp 0761: Logarithmische Darstellungen II - doppelogarithmische Skala

 von Klaus Langbein

Schwierigkeitsgrad:

Verwendete API-Aufrufe: keine

Download: Download des Beispielprojektes [4.6 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 prjLogLog.vbp  ------------
'----- Anfang Formular "frmLogLog" alias frmLogLog.frm  -----
' Steuerelement: Schaltfläche "cmdDraw"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Doppel-logarithmische Darstellung der Parabel über 6 Dekaden

' In wissenschaftlichen Anwendungen ist es gelegentlich von Vorteil,
' Kurven auf logarithmischen Skalen darzustellen. Mit Hilfe der
' doppelogarithmischen Darstellung ist es z.B. Möglich den Exponenten
' einer Kurve zu bestimmen, indem man die Steigung der Kurve in der
' doppellogarithischen darstellung mißt.

' Hier wird anhand der Parabel gezeigt, wie eine solche Darstellung
' erfolgen kann. Die Ausgabe der Kurven wird, ähnlich wie bei Kurven mit
' linearer Skala gemacht. Innerhalb der Skalierungsfunktionen
' hier xxc() und yyc() wird jedoch logarithmiert um die Position in
' Einheiten des Ausgabegeräts (Picturebox, Drucker) zu berechnen.
'
' Die Parabel wird in doppellogarithmischer Darstellung zur Geraden. Man
' beachte, dass der Wert 0 nicht auf der logarithmischen Skala dargestellt
' werden kann. Negative Werte können nur als Absolutbetrag eingetragen
' werden.
'
'
' K. Langbein, ActiveVB.de, 2007

'Option Explicit ' Für die ganz Ängstlichen
'
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 LowDecX As Long
Dim HighDecX As Long
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 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
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 DrawParabola()

    Dim xStep As Double
    Dim n As Double
    Dim X As Double
    Dim Y As Double


    Picture1.ForeColor = vbBlue
    Picture1.DrawWidth = 1
    X = xMin
    n = 2
    Y = X ^ n
    Picture1.PSet (xxc(X), yyc(Y))

    xStep = 10 ^ (LowDecX + 0)
    For X = xMin To 10 ^ (HighDecX + 0) Step xStep
    
        Y = X ^ n
        If Y <> 0 Then
            Picture1.Line -(xxc(X), yyc(Y))
        End If
    Next X

End Function

Private Function DrawScale()

    Dim Decade As Long
    Dim g 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 xs As Double
    Dim xe As Double
    
    Picture1.Cls
    Set Picture1.Picture = Nothing
    Picture1.DrawWidth = 1
    Picture1.FontName = "Arial"
    Picture1.FontBold = False
    Picture1.FontSize = 8
    th = Picture1.TextHeight("H")
    
    g = 180
    Grey = RGB(g, g, g)
    xxmin = xxc(xMin)
    xxmax = xxc(xMax)
    yymin = yyc(yMin)
    yymax = yyc(yMax)
    
    Picture1.Line (xxmin, yymax)-(xxmax, yymin), Grey, B
    
    For Decade = LowDecX To HighDecX
    
        xs = 10 ^ Decade
        xe = 10 ^ (Decade + 1)
                
        For X = xs + k * xs To xe Step xs
        
            xx = xxc(X)
            Picture1.Line (xx, yymin)-(xx, yymax), Grey
            
            Fmt$ = "0"
            If Decade < 0 Then
                Fmt$ = Fmt$ & "." & String$(Abs(Decade), "0")
            End If
            
            Txt = Format$(X, Fmt$)
            tx = Replace(Txt, "0", "")
            tx = Replace(tx, ".", "")
            tx = Replace(tx, ",", "")

            Select Case Val(tx)
            Case 1
                tw = Picture1.TextWidth(Txt)
                Picture1.CurrentX = xx - tw / 2
                Picture1.CurrentY = yymin + 2
                Picture1.ForeColor = 0
                If c > 0 Then
                    Picture1.Print Txt
                End If
            End Select
            c = c + 1
            
        Next X
        k = 1
    Next Decade
    
    k = 0
    For Decade = LowDecY To HighDecY
    
        ys = 10 ^ Decade
        ye = 10 ^ (Decade + 1)
        
        For Y = ys + k * ys To ye 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 Val(tx)
            Case 1, 2, 4, 6
                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
    Next Decade
    
    Picture1.ForeColor = 0
    Picture1.DrawWidth = 1
    
    For Decade = LowDecY To HighDecY
    
        yy = yyc(10 ^ Decade)
        Picture1.Line (xxmin, yy)-(xxmax, yy)
         
    Next Decade
    
    For Decade = LowDecX To HighDecX
    
        xx = xxc(10 ^ Decade)
        Picture1.Line (xx, yymin)-(xx, yymax)
        
    Next Decade
    
    Picture1.DrawWidth = 1
    Picture1.Line (xxmin, yymax)-(xxmax, yymin), , B
    
    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)
    
    Txt$ = "Y"
    Picture1.CurrentX = 400
    Picture1.CurrentY = Picture1.ScaleHeight / 2
    Picture1.Print Txt$;
    tw = Picture1.TextWidth(Txt$)
    xx = 400 + tw / 2
    yy = Picture1.CurrentY - 100
    
    Call MiniArrow(Picture1, xx, yy, xx, yy - 500)
    
    Picture1.FontSize = 11
    Picture1.FontBold = False
    Txt$ = "Doppellogarithmische Darstellung der Parabel"
    tw = Picture1.TextWidth(Txt$)
    Picture1.CurrentY = 150
    Picture1.CurrentX = MarginLeft + (xxmax - xxmin) / 2 - tw / 2
    Picture1.Print Txt$
    
End Function

Sub Fact()

    Dim w As Double
    Dim h As Double
    
    yMin = Log(10 ^ LowDecY) / Log(10)
    yMax = Log(10 ^ (HighDecY + 1)) / Log(10)
    
    xMin = Log(10 ^ LowDecX) / Log(10)
    xMax = Log(10 ^ (HighDecX + 1)) / Log(10)
    
    w = (Picture1.ScaleWidth - MarginLeft - MarginRight)
    h = (Picture1.ScaleHeight - MarginTop - MarginBottom)
    xFact = w / (xMax - xMin) ' Umrechnungsfaktoren
    yFact = h / (yMax - yMin)
    'xfact = yfact ' dies kann man einstellen, wenn man qudaratische
                   ' Dekaden-Kästchen haben möchte
    '
    xOff = 0 + MarginLeft + Abs(xMin) * xFact
    yOff = 0 + MarginTop + yMax * yFact
    yFact = -yFact
    
    xMin = 10 ^ xMin
    xMax = 10 ^ xMax
    
    yMin = 10 ^ yMin
    yMax = 10 ^ yMax
    
End Sub

Function xxc(ByVal X As Double) As Long

    xxc = xOff + Log(X) / Log(10) * 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 = 1200
    MarginRight = 500
    MarginTop = 600
    MarginBottom = 600
    
    ' Minimal- und Maximalwerte des Diagramms (unabh. von der Ausgabe)
    LowDecX = -1
    HighDecX = 2
        
    LowDecY = -2 ' Dekadennummern: -1 ist die Dekade,
    HighDecY = 3 ' die bei 0.1 anfängt und bei 1 aufhört.

    Call Fact
    Call DrawScale
    Call DrawParabola

End Sub

Private Sub Form_Load()

    Me.Height = 10000
    Picture1.AutoRedraw = True
    Picture1.Backcolor = vbWhite
    Picture1.Move Picture1.Left, Picture1.Top, 7000, 9000
    cmdDraw.Caption = "Draw"
    
End Sub


'------ Ende Formular "frmLogLog" alias frmLogLog.frm  ------
'------------- Ende Projektdatei prjLogLog.vbp  -------------