Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0614: Eine Kugel grafisch darstellen

VB 5/6-Tipp 0614: Eine Kugel grafisch darstellen

 von Jonathan Haas

Schwierigkeitsgrad:

Verwendete API-Aufrufe: keine

Download: Download des Beispielprojektes [2,83 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 Kugel.vbp  --------------
'--------- Anfang Formular "Form1" alias Kugel.frm  ---------
' Steuerelement: Horizontale Scrollbar "HScroll2"
' Steuerelement: Horizontale Scrollbar "HScroll1"
' Steuerelement: Vertikale Scrollbar "VScroll1"
' Steuerelement: Bildfeld-Steuerelement "Picture1"

Option Explicit

Const Pi As Double = 3.14159265358979

Function Atann(x, y) As Double
    Dim alpha As Double
    Dim atan As Double
    
    If x <> 0 Then
        atan = Atn(Abs(y) / Abs(x))
    Else
        atan = 0
    End If
    
    Select Case x
        Case Is > 0
            If y >= 0 Then
                ' 1st quad
                alpha = atan
            Else
                ' 4th quad
                alpha = 2 * Pi - atan
            End If
        
        Case Is < 0
            If y >= 0 Then
                ' 2nd quad
                alpha = Pi - atan
            Else
                ' 3rd quad
                alpha = atan + Pi
            End If
        
        Case Is = 0
           Select Case y
            Case Is > 0
                ' 1st
                alpha = Pi / 2
            Case Is < 0
                ' 3rd
                alpha = 3 * Pi / 2
            Case Is = 0
                alpha = 0
            End Select
    End Select

'us_atann:
    Atann = alpha - Pi / 2
    Atann = Atann / Pi * 180
    Atann = (Atann + 180) Mod 360
End Function




Private Sub paintball(radius As Double, coX As Double, coY As Double, _
    lightpitch As Double, lightyaw As Double, _
    dotrad As Double, pic As PictureBox, _
    r As Byte, g As Byte, b As Byte)
    
'radius:              Der Radius der Kugel
'coX,coY:             Der Mittelpunkt der Kugel
'lightpitch,lightyaw: Der Winkel des Lichts (0 bin 360)
'dotrad:              Der radius des hellen punktes auf der Kugel (0 bis 1)
'pic:                 Die Picturebox auf die gezeichent werden soll.
'                         Auchtung: Scalemode muss vbPixel sein.
'r,g,b:               Die Farbe der Kugel

    'Wie stark die Kugel glänzen soll (0-255)
    Const glanz = 64
    pic.Cls
    
    Dim x As Long, y As Long
    Dim degrees As Double, z As Double
    Dim color As Double, z2 As Double
    Dim brightnessA As Double, brightnessB As Double
    Dim brightnessc As Double
    Dim dx As Double, dy As Double
    Dim dz As Double
    
    For x = -radius To radius
        For y = -radius To radius
            z2 = Sqr(x * x + y * y)
            If z2 < radius Then
                degrees = Atann(x, y)
                z = Sqr(1 - (z2 / radius) ^ 2)
                dz = degrees
                dx = Atann(z * radius, x)
                dy = Atann(z * radius, y)
                color = similardeg(dx, lightyaw, dy, lightpitch)
                color = color - (1 - dotrad)
                color = color / dotrad / 2
                If color < 0 Then color = 0
                color = color * 2
                color = RGB(color * (r + glanz) + color + r / 2, _
                            color * (g + glanz) + color + g / 2, _
                            color * (b + glanz) + color + b / 2)
                    
                'color = RGB(z * 255, 0, 0)
                pic.PSet (coX + x - radius, coY + y - radius), color
            End If
        Next y
    Next x
    
    'sonne malen
    x = -Cos(lightyaw / 180 * Pi) * 2 * radius
    y = -Cos(lightpitch / 180 * Pi) * 2 * radius
    pic.DrawWidth = 10
    pic.PSet (coX + x - radius, coY + y - radius), RGB(255, 255, 0)
    pic.DrawWidth = 1
End Sub

Private Function similardeg(p1 As Double, p2 As Double, _
    p3 As Double, p4 As Double) As Double
    
    'diese Funktion prüft, ob die Ausrichtung von 2 Graden ählich ist.
    'Alle Graden werden in winkeln angegeben.
    similardeg = 360 - Sqr((p1 - p2) ^ 2 + (p3 - p4) ^ 2)
    similardeg = similardeg / 360
End Function

Private Function arcussinus(x As Double) As Double
    arcussinus = Atn(x / Sqr(-x * x + 1)) / Pi * 180
End Function

Private Sub Form_Paint()
    HScroll1_Change
End Sub

Private Sub HScroll1_Change()
    paintball 50, 200, 200, VScroll1.Value, HScroll1.Value, _
        HScroll2.Value / 32767, Picture1, 64, 128, 192
End Sub

Private Sub HScroll2_Change()
    HScroll1_Change
End Sub

Private Sub VScroll1_Change()
    HScroll1_Change
End Sub
'---------- Ende Formular "Form1" alias Kugel.frm  ----------
'--------------- Ende Projektdatei Kugel.vbp  ---------------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 1 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.