Tipp 0510 Funktions-Plotter
Autor/Einsender:
Datum:
  Marc Ermshaus
17.08.2006
Entwicklungsumgebung:   VB 6
Dieser Tipp zeigt eine einfache Möglichkeit zur Laufzeit festlegbare Funktionen zu berechnen und in eine PictureBox zu zeichnen (plotten). Zur Berechnung der Funktionswerte wird das Microsoft Scripting Control verwendet, da es die komplette Funktionalität der VB-Funktionen (Sin-, Cos-, Sqr-Funktion, usw.) zur Verfügung stellt. Die Funktionsterme müssen jedoch in korrektem VB-Syntax eingegeben werden.
Da dieses Beispiel lediglich die Möglichkeiten des Zeichnens von Funktionen aufzeigt und um die Übersichtlichkeit des Codes zu wahren, ist das Abfangen von Eingabefehlern ist nur minimal implementiert. Auch ist die Zeichengeschwindigkeit sicherlich nicht perfekt optimiert, aber so bieten sich genügend Anreize dieses Beispiel auszubauen.
 
Option Explicit

Private Type UDT_WERTEPAAR
  X   As Double
  Y   As Double
  Err As Boolean
End Type

Private Const X1 As Double = (-5)
Private Const X2 As Double = 5
Private Const Y1 As Double = 5
Private Const Y2 As Double = (-5)

Private aWerte() As UDT_WERTEPAAR
Private lBerechnungsschritte As Long

Private Sub Form_Load()
  ZeichenflächeInitialisieren
  cboFunktionsterm.AddItem "x+3-2"
  cboFunktionsterm.AddItem "x^2+y^2"
  cboFunktionsterm.AddItem "x^3+y^3"
  cboFunktionsterm.AddItem "y^2-x^2"
  cboFunktionsterm.AddItem "3*x^3+7*x^2+6*x"
  cboFunktionsterm.ListIndex = 0
End Sub

Private Sub cmdFunktionZeichnen_Click()
  lBerechnungsschritte = CLng(txtBerechnungsschritte.Text)
  If (chkBildflächeLöschen.Value = 1) Then
    picFunktion.Cls
    ZeichenflächeInitialisieren
  End If

  FunktionswerteErmitteln
  FunktionZeichnen
End Sub

Private Sub FunktionswerteErmitteln()
  Dim bFehler As Boolean
  Dim X       As Double
  Dim Y       As Double
  Dim l       As Long
  Dim sTemp   As String

  ReDim aWerte(0 To (lBerechnungsschritte))
  X = X1
  For l = 0 To (lBerechnungsschritte)
    bFehler = False
    sTemp = cboFunktionsterm.Text
    sTemp = Replace(sTemp, "x", X)
    sTemp = Replace(sTemp, ",", ".")

    On Error GoTo errHandler
    Y = sclFunktion.Eval(sTemp)
    If (bFehler = False) Then
      With aWerte(l)
        .X = X
        .Y = Y
        .Err = False
      End With
    Else
      With aWerte(l)
        .X = X
        .Y = 0
        .Err = True
      End With
    End If
    X = X + (X2 - X1) / lBerechnungsschritte
  Next l

  Exit Sub

errHandler:
  bFehler = True
  Resume Next
End Sub

Private Sub FunktionZeichnen()
  Dim l As Long

  picFunktion.DrawStyle = 0
  picFunktion.ForeColor = vbBlue
  picFunktion.DrawWidth = 1

  For l = 0 To lBerechnungsschritte
    If (aWerte(l).Err = False) Then
      If (aWerte(l).Y < Y1) And (aWerte(l).Y > Y2) Then
        picFunktion.PSet (aWerte(l).X, aWerte(l).Y)
        DoEvents
      End If
    End If
  Next l
End Sub

Private Sub ZeichenflächeInitialisieren()
  Dim a As Double
  Dim b As Double
  Dim i As Integer

  picFunktion.AutoRedraw = True
  picFunktion.Scale (X1, Y1)-(X2, Y2)

  picFunktion.DrawStyle = 2
  picFunktion.ForeColor = &HE0E0E0

  a = Y2
  For i = 1 To 10
    picFunktion.Line (X1, a)-(X2, a)
     a = a + (Y1 - Y2) / 10
  Next i

  a = X1
  For i = 1 To 10
    picFunktion.Line (a, Y1)-(a, Y2)
    a = a + (X2 - X1) / 10
  Next i

  picFunktion.DrawStyle = 0
  picFunktion.ForeColor = &H0
  picFunktion.Line (X1, 0)-(X2, 0)
  picFunktion.Line (0, Y1)-(0, Y2)

  picFunktion.ForeColor = &H0

  a = X1
  b = 0
  For i = 1 To 10
    picFunktion.CurrentX = a
    picFunktion.CurrentY = b
    picFunktion.Print Format(a, "#0.00")
      a = a + (X2 - X1) / 10
  Next i

  a = 0
  b = Y2
  For i = 1 To 10
    picFunktion.CurrentX = a
    picFunktion.CurrentY = b
    picFunktion.Print Format(b, "#0.00")
    b = b + (Y1 - Y2) / 10
  Next i
End Sub

Private Sub picFunktion_MouseMove(Button As Integer, _
      Shift As Integer, X As Single, Y As Single)

  Dim sPosition As String
  sPosition = "(" & Format(X, "0.00") & " | " & _
              Format(Y, "0.00") & ")"

  If (lblMausposition.Caption <> sPosition) Then
    lblMausposition.Caption = sPosition
  End If
End Sub
 
Hinweis
Um diesen Tipp ausführen zu können, muss das Microsoft Script Control als Komponente in das Projekt eingebunden werden.

Windows-Version
95
98/SE
ME
NT
2000
XP
Vista
Win 7
VB-Version
VBA 5
VBA 6
VB 4/16
VB 4/32
VB 5
VB 6


Download  (5 kB) Downloads bisher: [ 704 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Donnerstag, 26. Mai 2011