Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0786: Kurven schnell darstellen, zoomen und scrollen

VB 5/6-Tipp 0786: Kurven schnell darstellen, zoomen und scrollen

 von Klaus Langbein

Schwierigkeitsgrad:

Verwendete API-Aufrufe: Polyline

Download: Download des Beispielprojektes [6,52 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 PrjWavView.vbp ------------
'---- Anfang Formular "frmWavView" alias frmWavView.frm  ----
' Steuerelement: Rahmensteuerelement "Frame1"
' Steuerelement: Schaltfläche "cmdZoom" (Index von 0 bis 1) auf Frame1
' Steuerelement: Beschriftungsfeld "Label1" auf Frame1
' Steuerelement: Vertikale Scrollbar "VScroll1"
' Steuerelement: Horizontale Scrollbar "HScroll1"
' Steuerelement: Schaltfläche "cmdPrint"
' Steuerelement: Schaltfläche "cmdDraw"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Kurven können in VB durch wiederholten Aufruf des Line-Befehls
' gezeichnet werden. Hat man jedoch einen große Anzahl an
' Datenpunkten und die Ausgabe soll möglichst schnell erfolgen,
' empfiehlt es sich den Polyline-Befehl einzusetzen.

' Zur Ausgabe einer Kurve werden zunächst die Koordinaten eines
' Feldes vom Typ PointApi berechnet. Bei dieser Umskalierung können
' auch Vergrößerungsfaktoren angegeben werden.
' Im vorliegenden Beispiel werden Daten, wie sie in einer 16-Bit-mono
' Wave-Datei vorliegen gegen die Zeit aufgetragen. Eine Zoomfunktion
' kann in X- und Y-Richtung angewandt werden und es ist möglich durch
' die Daten zu Scrollen.

'Option Explicit       ' Wer's braucht wird selig
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 Double ' Ränder in Bildschirmeinheiten (Pixel, Twipps)
Dim MarginTop As Double
Dim MarginRight As Double
Dim MarginBottom As Double
'
Dim xFact As Double
Dim yFact As Double
Dim xOff As Double
Dim yOff As Double

Dim DiagLeft As Long
Dim DiagTop As Long
Dim DiagWidth As Long
Dim DiagHeight As Long

Dim Zoom As Double

Private Type PointApi
    X As Long
    Y As Long
End Type

Dim Pt() As PointApi
Dim Data() As Integer
Dim nSamples As Long
Dim Win9x As Boolean
Dim BlockAction As Boolean
Dim MaxScroll As Double
Dim Perc As Double
Dim PtStart As Long

Private Declare Function Polyline Lib "gdi32" ( _
                ByVal hdc As Long, _
                lpPoint As PointApi, _
                ByVal nCount As Long) As Long
                

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

Private Function Create(ByVal n As Long, ByVal ForceNew As Boolean) As Long

    On Error Goto err1

    Dim Fn$
    Dim F As Double
    Dim w As Double
    Dim pi As Double
    Dim t As Double
    Dim tStep As Double
    Dim Y() As Integer
    Dim A As Long
    Dim Fl As Long
    Dim fno As Long
    Dim i As Long
    
    ReDim Data(1 To n)
    pi = 4 * Atn(1)
    
    Fn$ = App.Path & IIf(Right$(App.Path, 1) = "\", "\", "") & "data.dat"
    If ForceNew = False Then
        Fl = FileLen(Fn)
        If Fl > 0 Then
            If Fl = 2 * n Then
                fno = FreeFile
                Open Fn$ For Binary As #fno
                Get #fno, , Data()
                Close #1
                Exit Function
            End If
        End If
    End If
    
    F = 100
    w = 2 * pi * F
    A = 32000
    tStep = 1 / 44100
    
    For i = 1 To n
        Data(i) = A * Sin(w * t) * Sin(w * 3.2 * t) ^ 3 * Sin(0.1 * w * t)
        t = t + tStep
    Next i
    
    fno = FreeFile
    Kill Fn
    fno = FreeFile
    Open Fn$ For Binary As #fno
    Put #fno, , Data()
    Close #1
    Exit Function
    
err1:
    Select Case Err
    Case 53
        Resume Next
    Case Else
        MsgBox Error$
    End Select

End Function

Function DrawBoundary(Obj As Object, ByVal Grey As Long) As Long
                      
    Obj.DrawWidth = 1
    Obj.ForeColor = RGB(Grey, Grey, Grey)
    'Obj.ForeColor = vbRed
    Obj.Line (DiagLeft, DiagTop)- _
             (DiagLeft + DiagWidth, DiagTop + DiagHeight), , B
                          
End Function

Private Function DrawData(Obj As Object, ByVal PtStart As Long, ByVal np As Long)

    Dim nMax As Long
    Dim k As Long
    Dim Rest As Long
    Dim i As Long
    Dim j As Long
    Dim Pos As Long
    Dim xx As Long
    Dim yy As Long
    Dim A As Double
    Dim IsPrinter As Boolean
    
    If TypeOf Obj Is Printer Then
        IsPrinter = True
    End If
    
    Obj.ForeColor = vbBlue
    Obj.DrawWidth = 1
    If IsPrinter = False Then
        Obj.Cls
    End If
    
    ReDim Pt(0 To np)
    Pt(0).X = -99999
    
    For i = 1 To np
        A = (VScroll1.Value / 10000) / 320
        xx = xxc((i - 1) * Zoom)
        yy = yyc(Data(i + PtStart - 1) * A)
        If xx <> Pt(j).X Or yy <> Pt(j).Y Then
            j = j + 1
            Pt(j).X = xx
            Pt(j).Y = yy
        End If
    Next i
    
    If Win9x = True Then
        nMax = 5000
        k = Int(j / nMax)
        Rest = (j - k * nMax)
        Pos = 1
        If k > 0 Then
            For i = 1 To k
                Polyline Obj.hdc, Pt(Pos), nMax
                Pos = Pos + nMax
            Next i
        End If
        If Rest > 0 Then
            Polyline Obj.hdc, Pt(Pos), Rest
        End If
    Else
        Polyline Obj.hdc, Pt(Pos), j
    End If
    
    If IsPrinter = False Then
        Obj.Refresh
    End If

End Function

Function DrawGridY(Obj As Object, ByVal yStep As Double, ByVal Grey As Long) 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
   
    Obj.ForeColor = RGB(Grey, Grey, Grey)
    Obj.DrawWidth = 1
    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, ByVal Grey As Long) As Long

    Dim xStart As Double
    Dim yyMax As Long
    Dim yyMin As Long
    Dim X As Double
    Dim xx As Long
    
    Obj.ForeColor = RGB(Grey, Grey, Grey)
    Obj.DrawWidth = 1
    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(Obj As Object, _
                  ByVal DrawFrame As Boolean, _
                  ByVal Grey As Long) As Long
    

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

End Function

Private Function DrawSection(Obj As Object)
    
    Dim np As Long
    
    If Zoom = 1 Then
        np = nSamples
    Else
        np = CLng((nSamples / Zoom))
    End If

    MaxScroll = nSamples - (nSamples / Zoom)
    Perc = HScroll1.Value / 10000
    PtStart = Int(Perc * MaxScroll) + 1
    
    Call DrawData(Obj, PtStart, np)

End Function

Function Fact() As Long

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

Function Legend(Obj As Object, 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
    Dim IsPrinter As Boolean
    Dim F As Double
    
    If TypeOf Obj Is Printer Then
        IsPrinter = True
        F = Obj.ScaleX(1, 6, 3) / 4
    Else
        F = 1
    End If
    
    Obj.DrawWidth = 1
    
    Obj.ForeColor = 0
    Obj.FontName = "Arial"
    Obj.FontSize = 12
    Obj.FontBold = False
    
    Text$ = Title
    tw = Obj.TextWidth(Text)
    '
    cnt = 0
    Do
        If tw > (xMax - xMin) * xFact Then
            Obj.FontSize = Obj.FontSize - 0.5
            tw = Obj.TextWidth(Text)
            cnt = cnt + 1
        Else
            Exit Do
        End If
    Loop Until Obj.FontSize < 3 Or cnt > 20
    
    th = Obj.TextHeight(Text)
    Obj.CurrentX = xxc(xMin + (xMax - xMin) / 2) - tw / 2
    Obj.CurrentY = yyc(yMax) - th - 5 * F
    Obj.Print Text$
'
    Obj.FontName = "Arial"
    Obj.FontSize = 11
    Obj.FontBold = True
    Text$ = LegendX$
    tw = Obj.TextWidth(Text)
    Obj.CurrentX = xxc(xMin + (xMax - xMin) / 2) - tw / 2
    Obj.CurrentY = yyc(yMin) + 5 * F
    Obj.Print Text$;
    X = Obj.CurrentX + 5 * F
    Y = yyc(yMin) + 15 * F
    Arrow90 Obj, X, Y, X + 30 * F, Y, 6 * F, 0
    
    Obj.FontName = "Arial"
    Obj.FontSize = 11
    Obj.FontBold = True
    Text$ = LegendY$
    tw = Obj.TextWidth(Text)
    Obj.CurrentX = xxc(xMin) - 20 * F
    Obj.CurrentY = yyc(0) - 10 * F
    Obj.Print Text$
    
    X = xxc(xMin) - 20 * F + tw / 2
    Y = yyc(0) - 10 * F
    Arrow90 Obj, X, Y, X, Y - 30 * F, 6 * F, 90

End Function


'Meßlatte:
'--------1---------2---------3---------4---------5---------6---------7------|
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 LegendX As String
    Dim IsPrinter As Boolean
    Dim PFact As Double
    
    If TypeOf Obj Is Printer Then
        IsPrinter = True
    End If
    
    Obj.ScaleMode = 3 ' Da API-Befehle zum Zeichnen verwendet werden,
                      ' arbeiten wir mit Pixeln
    
    ' Festlegen der Position und Größe des gesamten Diagramms auf dem
    ' Ausgabegerät (z.B. Picturbox). Einheiten sind hier Pixel, da API-
    ' Befehle zum Zeichnen verwendet 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.
    
    If IsPrinter = False Then
        DiagLeft = 10
        DiagTop = 10
        DiagWidth = Obj.ScaleWidth - DiagLeft - 10
        DiagHeight = Obj.ScaleHeight - DiagTop - 10
        
        ' Festlegen der Ränder innerhalb des Diagramms. Einheiten sind
        ' ebenfalls die voreingestellten Einheiten (Scalemode) des Objekts.
        MarginLeft = 40
        MarginTop = 40
        MarginRight = 10
        MarginBottom = 30
    Else
        PFact = Obj.ScaleX(1, 6, 3) ' Faktor zur Umrechnung von mm auf Pixel
        DiagLeft = 25 * PFact
        DiagTop = 30 * PFact
        DiagWidth = Obj.ScaleWidth - DiagLeft - 25 * PFact
        DiagHeight = DiagWidth * 0.4
        
        ' Festlegen der Ränder innerhalb des Diagramms. Einheiten sind
        ' ebenfalls die voreingestellten Einheiten (Scalemode) des Objekts.
        MarginLeft = 12 * PFact
        MarginTop = 8 * PFact
        MarginRight = 1 * PFact
        MarginBottom = 10 * PFact
        
    End If
    
    ' Festlegen der Maximalwerte. Einheiten sind hier die geräteunabhängigen
    ' Einheiten des Diagramms (z.B. m, km, kg, Anzahl, usw.).
    nSamples = UBound(Data) - LBound(Data) + 1
    xMax = nSamples
    xMin = 0
    yMax = 120
    yMin = -120

    ' Faktoren und Offsets berechnen
    Call Fact

    ' Zeichnung vorbereiten
    If IsPrinter = False Then
        Obj.Cls
        Set Obj.Picture = Nothing
    End If
    ' Zunächst die Grenzen des Diagramms einzeichnen. Dies dient nur
    ' zur Kontrolle und kann später weggelassen werden.
    Call DrawBoundary(Obj, 200)
    
    ' Gitter, Achsen und Rahmen der Zeichenfläche ausgeben
    Call DrawGridY(Obj, yMax / 6, 220)
    Call DrawGridX(Obj, xMax / 10, 220)
    Call DrawAxis(Obj, True, 120)
    
    LegendX = "Zeit (" & Format$(100 / Zoom) & " ms/Div.)"
    Call Legend(Obj, LegendX, "y", "Amplitudenverlauf")

    
    If IsPrinter = False Then
        Set Obj.Picture = Obj.Image
    End If
    
End Function

Function xxc(ByVal X As Double) As Double

    xxc = xOff + xFact * X

End Function

Function yyc(ByVal Y As Double) As Double

    yyc = yOff + yFact * Y

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

Private Sub cmdPrint_Click()

   Printer.Print " "
   Call Plot(Printer)
   Call DrawSection(Printer)
   Printer.EndDoc
   
End Sub

Private Sub cmdZoom_Click(Index As Integer)

    MaxScroll = nSamples - (nSamples / Zoom)
    Perc = HScroll1.Value / 10000
    PtStart = Int(Perc * MaxScroll)
    
    Select Case Index
    Case 0
        Zoom = Zoom / 2
        If Zoom < 1 Then
            Zoom = 1
        End If
    Case 1
        Zoom = Zoom * 2
        If Zoom > 4096 Then
            Zoom = 4096
        End If
    End Select
    
    If Zoom > 1 Then
        HScroll1.Enabled = True
        BlockAction = True
        MaxScroll = nSamples - (nSamples / Zoom)
        Perc = PtStart / MaxScroll
        If Perc > 1 Then Perc = 1
        HScroll1.LargeChange = HScroll1.Max * (1 / Zoom)
        HScroll1.Value = Perc * 10000
        BlockAction = False
    Else
        HScroll1.Enabled = False
    End If
    
    Call Plot(Picture1)
    Call DrawSection(Picture1)
    
End Sub

Private Sub Form_Activate()
    cmdDraw_Click
End Sub

Private Sub Form_Load()

    cmdDraw.Move 90, 60
    cmdPrint.Move cmdDraw.Left + cmdDraw.Width, 60
    cmdDraw.Caption = "Draw"
    cmdPrint.Caption = "Print"
    
    Picture1.AutoRedraw = True
    Picture1.BackColor = vbWhite
    Picture1.ScaleMode = 3
    Picture1.Move 90, 450
    Zoom = 1
    Win9x = True
    Call Create(44100, False)
    
End Sub

Private Sub Form_Resize()

    Dim h As Single
    Dim w As Single
    
    With Picture1
        h = ScaleHeight - .Top - .Left - HScroll1.Height
        w = ScaleWidth - 2 * .Left - VScroll1.Width
        .Move .Left, .Top, w, h
        HScroll1.Move .Left, .Top + .Height, .Width
        VScroll1.Move .Left + .Width, .Top, VScroll1.Width, .Height
        Frame1.Move .Left + .Width - Frame1.Width
    End With
    
    Call Plot(Picture1)
    
End Sub

Private Sub HScroll1_Change()

    Dim np As Long
    
    If BlockAction = True Then
        Exit Sub
    End If

    Call DrawSection(Picture1)
    
End Sub

Private Sub HScroll1_Scroll()
    HScroll1_Change
End Sub


Private Sub VScroll1_Change()
    Call DrawSection(Picture1)
End Sub

Private Sub VScroll1_Scroll()
    VScroll1_Change
End Sub

'----- Ende Formular "frmWavView" alias frmWavView.frm  -----
'------------- Ende Projektdatei PrjWavView.vbp -------------