Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0745: Kreisbogen, Winkel und Pfeilspitzen zeichnen

VB 5/6-Tipp 0745: Kreisbogen, Winkel und Pfeilspitzen zeichnen

 von Klaus Langbein

Schwierigkeitsgrad:

Verwendete API-Aufrufe: keine

Download: Download des Beispielprojektes [4,47 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 Project1.vbp -------------
' --------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Horizontale Scrollbar "HScroll1" (Index von 1 bis 2)
' Steuerelement: Textfeld "Text1" (Index von 1 bis 2)
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Figur-Steuerelement "Handle" (Index von 1 bis 2) auf Picture1
Dim ix As Integer
Dim xoff As Long
Dim yoff As Long
Dim xfact As Double
Dim yfact As Double
Dim xmax As Double
Dim ymax As Double
Dim Pi As Double
Dim RPD As Double
Dim BlockAction As Boolean

Function Atan(ByVal X As Double, ByVal Y As Double) As Double

    Dim Alpha As Double
    Dim ArcTan As Double
    
    Const Pi = 3.14159265358979
    
    If X <> 0 Then
    
        ArcTan = Atn(Abs(Y) / Abs(X))
        
    Else
    
        ArcTan = 0
        
    End If
    
    Select Case X
    
    Case Is > 0
    
        If Y >= 0 Then
        
            Alpha = ArcTan    ' 1st quad
            
        Else
        
            Alpha = 2 * Pi - ArcTan  ' 4th quad
            
        End If
        
    Case Is < 0
    
        If Y >= 0 Then
        
            Alpha = Pi - ArcTan ' 2nd quad
            
        Else
        
            Alpha = ArcTan + Pi ' 3rd quad
            
        End If
        
    Case Is = 0
    
        Select Case Y
        
        Case Is > 0
            Alpha = Pi / 2   ' 1st
            
        Case Is < 0
            Alpha = 3 * Pi / 2  ' 3rd
            
        Case Is = 0
            Alpha = 0
            
        End Select
    End Select
    
    Atan = Alpha
    
End Function

Sub Draw()

    Dim Alpha As Double
    Dim Teta(2) As Double
    Dim Beta(2) As Double
    Dim i As Long
    Dim x1 As Double
    Dim y1 As Double
    Dim x2 As Double
    Dim y2 As Double
    Dim xpix1 As Long
    Dim ypix1 As Long
    Dim xpix2 As Long
    Dim ypix2 As Long
    Dim Txt$
    
    ' 234567890'234567890'234567890'234567890'234567890'234567890'234567890'23
    ' 4567890
    Picture1.Cls ' Erstmal die Tafel sauberwischen
    Picture1.DrawWidth = 1
    
    '                 /|
    '                / |
    '             c /  | b
    '              /   |
    '             /    |
    '             ------
    '               a
    '
    '   Apha ist der Winkel zw. a und c
    For i = 1 To 2
    
        Alpha = Val(Text1(i).Text) ' Texbox auslesen - das ist der Winkel
                                   ' in Grad
                                   
        If Alpha > 360 Then ' Korrekturen vornehmen, wenn zu große Winkel
                            ' angegeben
                            
            Alpha = 360     ' wurden
            
        End If
        
        If Alpha < 0 Then
        
            Alpha = 0
            
        End If
        
        Teta(i) = Alpha * RPD ' Winkel im Bogenmaß errechnen.
        c = xmax * 0.8 ' das legen wir mal willkürlich fest - man kann
        
        ' einsetzen was man will
        ' Jetzt berechnen wir die Höhe und Breite des rechtwinkligen
        ' Dreiecks, also, Kathete und die Gegenkathete.
        ' Wir kennen die Strecke c, die Hypotenuse, daher können wir
        ' a nach der Formel a = c * cos (teta) und b = c * Sin(teta)
        ' berechnen:
        a = c * Cos(Teta(i))
        b = c * Sin(Teta(i))
        y1 = 0      ' jetzt füllen wir die Koordinatenpaare unserer Linie
        x1 = 0
        x2 = x1 + a ' Diesen Zwischenschritt brauchen wir, um von de Längen
        y2 = y1 + b ' auf die neue Position zu schließen.
        
        ' Nun rechnen wir von mathematischen Koordinaten in Pixel
        ' um. x und y könnten ja in Metern oder kM angegeben sein.
        ' Daher benötigen wir einen Umrechnungsfaktor xfact und yfact.
        ' xfact wird entsprechend dem Maximalwert, den wir darstellen
        ' wollen festgelegt.
        ' In X-Richtung ist die Berechnung einfach: wir addieren zu unser
        ' Anfangsposition xoff einfach x * xfact dazu.
        '
        ' Da das Koordinatensystem am Bildschirm auf dem Kopf steht
        ' müssen wir das korrigieren. Das geschieht, in dem wir von der
        ' Mitte ausgehend (yoff = Offset in y-Richtung) nach oben rechnen
        ' (das geschieht indem wir den Faktor in y-Richtung negativ einsetzen)
        ' so und umrechnen:
        xpix1 = xoff + x1 * xfact ' Diesen Teil kann man später, wenn man
                                  ' weiß,
        ypix1 = yoff - y1 * yfact ' was man tut, in eine Funktion auslagern.
        xpix2 = xoff + x2 * xfact
        ypix2 = yoff - y2 * yfact
        Picture1.Line (xpix1, ypix1)-(xpix2, ypix2)
        Handle(i).Move xpix2 - 2, ypix2 - 2
        
    Next i
    
    ' So nun wird noch ein Bogen gemalt. Man beachte, dass VB hier einen
    ' Bug hat. Positive Winkel werden offensichtlich gegen den Uhrzeigersinn
    ' nach oben gezeichnet, obwohl das Koordinatensystem der Picturebox
    ' ja positive y-Werte nach unten darstellt. Wir können Teta also einfach
    ' als Endwinkel übernehmen.
    R = c * 0.6  ' Radius des Bogens festlegen
    Picture1.Circle (xpix1, ypix1), R * xfact, 0, Teta(2), Teta(1)
    
    ' Und nun noch ein Schmankerl: Wir zeichen eine Pfeilspitze an das
    ' Ende des Bogens, indem wir einen gefüllten Kreisausschnitt zeichen.
    ' Die Kunst besteht darin, die Winkel für das Kreissegment zu
    ' bestimmen.
    ' Erst die Endposition des Bogens bestimmen - hier kommt der
    ' Kreismittelpunkt hin
    x1 = R * Cos(Teta(1))
    y1 = R * Sin(Teta(1))
    xpix1 = xoff + x1 * xfact
    ypix1 = yoff - y1 * yfact
    R = xmax / 15 ' Einen neuen Radius festlegen - die Länge der Pfeilspitze
    d = 0.2 ' Das ist der halbe Öffnunswinkel der Spitze
    
    ' Jetzt berechnen wir die Winkel für den Kreisausschnitt
    ' wir addieren 3 halbe Pi zu Teta hinzu und rechen noch d dazu oder ab.
    Beta(1) = Teta(1) + 1.5 * Pi - 1.9 * d ' bei Beta(1) muss es etwas mehr
                                           ' sein.
    Beta(2) = Teta(1) + 1.5 * Pi + d
    
    For i = 1 To 2                     ' Korrekturen vornehen
    
        If Beta(i) > 2 * Pi Then       ' Das kann passieren - die
                                       ' Circle-Funktion
                                       
            Beta(i) = Beta(i) - 2 * Pi ' mag das nicht
            
        End If
        
    Next i
    
    ' Und hokus-pokus kommt die Pfeilspitze dran - und zwar immer
    ' im richtigen Winkel. Wenn die Winkel mit negativem Vorzeichen
    ' angegeben werden wird das Kreissegment, also die Pfeilspitze, gefüllt.
    Picture1.FillStyle = 0
    Picture1.Circle (xpix1, ypix1), R * xfact, 0, -Beta(1), -Beta(2)
    
    ' So nu noch die Beschriftung
    Picture1.FontName = "Arial"
    Picture1.FontSize = 11
    
    ' Öffnungswinkel zw. beiden Geraden bestimmen:
    Beta(0) = Teta(1) - Teta(2)
    
    If Beta(0) < 0 Then
    
        Beta(0) = 2 * Pi + Beta(0)
        
    End If
    
    Alpha = Beta(0) / RPD ' Das ist der Winkel in Grad
    
    ' Ausgabeposition für den Winkel als Text berechnen
    R = c / 4 ' Radius festlegen, bei dem der Text erscheint
    x2 = R * Cos(Teta(2) + Beta(0) / 2)
    y2 = R * Sin(Teta(2) + Beta(0) / 2)
    
    ' Koodrinaten in Pixeln bestimmen:
    xpix2 = xoff + x2 * xfact
    ypix2 = yoff - y2 * yfact
    
    ' Bei der Textposition nehmen wir noch eine kl. Korrektur vor
    Txt$ = Format$(Alpha, "0") & Chr$(176)
    Picture1.CurrentX = xpix2 - Picture1.TextWidth(Txt) / 3
    Picture1.CurrentY = ypix2 - Picture1.TextHeight(Txt$) / 2
    Picture1.Print Txt$
    Picture1.Refresh
    
End Sub

Private Sub Form_Load()

    Picture1.AutoRedraw = True
    Picture1.ScaleMode = 3
    Picture1.Width = 5055
    Picture1.Height = Picture1.Width
    xoff = Picture1.ScaleWidth / 2
    yoff = Picture1.ScaleHeight / 2
    xmax = 20
    ymax = xmax
    xfact = (Picture1.ScaleWidth / 2) / xmax
    yfact = xfact
    Pi = 4 * Atn(1)
    RPD = Atn(1) / 45
    HScroll1(1).Min = 0
    HScroll1(1).Max = 360
    HScroll1(1).LargeChange = 10
    HScroll1(1).Value = 30
    HScroll1(2).Min = 0
    HScroll1(2).Max = 360
    HScroll1(2).LargeChange = 10
    HScroll1(2).Value = 0
    Text1(1).Text = Format$(HScroll1(1).Value)
    Text1(2).Text = Format$(HScroll1(2).Value)
    
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As _
    Single, Y As Single)
    
    ' 234567890'234567890'234567890'234567890'234567890'234567890'234567890'23
    ' 4567890
    ix = 0
    
    For i = 1 To 2
    
        If Y >= Handle(i).Top And Y < Handle(i).Top + Handle(i).Height Then
        
            If X >= Handle(i).Left And X < Handle(i).Left + Handle(i).Width _
                Then
                
                ix = i
                
                Exit For
                
            End If
        End If
        
    Next i
    
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As _
    Single, Y As Single)
    
    If Button = 1 Then
        If ix <> 0 Then
        
            dx = X - xoff
            dy = yoff - Y
            Alpha = Atan(dx, dy)
            Text1(ix).Text = Format$(Alpha / RPD, "0.00")
            
            Call Text1_KeyDown(ix, 13, 0)
            
        End If
    End If
    
End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As _
    Single, Y As Single)
    
    ix = 0
    
End Sub

Private Sub Text1_KeyDown(Index As Integer, KeyCode As Integer, Shift As _
    Integer)
    
    Select Case KeyCode
    
    Case 13
        BlockAction = True
        HScroll1(Index).Value = Val(Text1(Index).Text)
        BlockAction = False
        
        Call Draw
        
    Case Else
    
    End Select
    
End Sub

Private Sub HScroll1_Change(Index As Integer)

    Text1(Index).Text = Format$(HScroll1(Index).Value, "0.00")
    
    Call Draw
    
End Sub

Private Sub HScroll1_Scroll(Index As Integer)

    HScroll1_Change (Index)
    
End Sub

' ---------- Ende Formular "Form1" alias Form1.frm  ----------
' -------------- Ende Projektdatei Project1.vbp --------------