Keskustelu: Koodit: VB6: Lentävät Neliöt

' LENTÄVÄT NELIÖT
' Author: Olli Moisio (oltzi@mbnet.fi)

Option Explicit

Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long

' *********** KONFFAUS ***********
Private Const NELIOMAARA As Integer = 20
'Kuinka monta neliötä piirretään. Pyörii AMD Athlon XP 1800+:llä sujuvasti noin 2000 neliöön asti,
'kun MINIMISIVUKOKO=0.05 ja MAKSIMISIVUKOKO=0.1
Private Const MINIMISIVUKOKO As Double = 0.1 'Minimikoko neliön sivulle, 0.1 = 10% ruudusta
Private Const MAKSIMISIVUKOKO As Double = 0.3 'Maksimikoko neliön sivulle, 0.3 = 10% ruudusta
Private Const MAKSIMIVAUHTI As Integer = 10 'Maksiminopeus pikseleinä yhden loopin aikana
Private Const PAIVITYSVALI As Integer = 20 'ms: 1000/20 = 50 fps
' ********** /KONFFAUS ***********

Private MAKSIMIXKOKO As Integer
Private MINIMIXKOKO As Integer
Private MAKSIMIYKOKO As Integer
Private MINIMIYKOKO As Integer

'Neliötyyppi
Private Type Nelio
    X1 As Integer 'Neliön vasemman yläkulman x-koordinaatti
    Y1 As Integer 'Neliön vasemman yläkulman y-koordinaatti
    leveys As Integer
    korkeus As Integer
    vari As Long
    xsuunta As Integer 'X-tason suunta: -1 = vasemmalle, 1 = oikealle
    ysuunta As Integer 'Y-tason suunta: -1 = ylöspäin, 1 = alaspäin
End Type

Private Neliot(NELIOMAARA - 1) As Nelio
Private Lopeta As Boolean 'Kun Lopeta = true, ohjelma päättyy

Private HIIRIX As Integer 'hiiren x-koordinaatti
Private HIIRIY As Integer 'hiiren y-koordinaatti

Private Sub Form_Click()
    Lopeta = True 'Klikkaus lopettaa ohjelman
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    Lopeta = True 'Mikä tahansa näppäin lopettaa ohjelman
End Sub

Private Sub Form_Load()
    Form1.BackColor = vbBlack
    Form1.AutoRedraw = True
    Form1.WindowState = 2
    Form1.ScaleMode = 3 'pikseleinä

    Form1.Show
    HIIRIX = 0
    HIIRIY = 0
    Lopeta = False

    Call SetCursorPos(Form1.ScaleWidth, Form1.ScaleHeight)
    ' Siirretään hiiri oikeaan alanurkkaan pois tieltä
    Alustus
    PaaLooppi
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
'Asettaa Lopeta-muuttujan arvoksi tosi, mikäli hiirtä liikutetaan
    If ((HIIRIX = 0) And (HIIRIY = 0)) Then
        HIIRIX = x
        HIIRIY = y
    Else
        If ((Abs(HIIRIX - x) > 20) Or (Abs(HIIRIY - y) > 20)) Then Lopeta = True
        'Jos hiiri liikkuu yli 20 pikseliä, lopetetaan
    End If
End Sub

Private Sub Form_Resize()
'Päivitetään muuttujat kun ikkunan kokoa muutetaan

    MAKSIMIXKOKO = Form1.ScaleWidth * MAKSIMISIVUKOKO
    MINIMIXKOKO = Form1.ScaleWidth * MINIMISIVUKOKO

    MAKSIMIYKOKO = Form1.ScaleHeight * MAKSIMISIVUKOKO
    MINIMIYKOKO = Form1.ScaleHeight * MINIMISIVUKOKO
    Alustus (True) 'Päivitetään neliöille uudet mitat, ei kosketa muihin arvoihin
End Sub

Private Sub Alustus(Optional OnlyResize As Boolean = False)
'Alustaa Neliöiden arvot, mikäli OnlyResize=true, muutetaan vain mitat
'Neliön nopeus on suoraan verrannollinen sen kokoon. Mitä isompi neliö,
'sitä hitaampi ja toisinpäin.

    Dim i As Integer
    Randomize
    For i = 0 To NELIOMAARA - 1
        Neliot(i).leveys = (Rnd * (MAKSIMIXKOKO - MINIMIXKOKO)) + MINIMIXKOKO
        Neliot(i).korkeus = (Rnd * (MAKSIMIYKOKO - MINIMIYKOKO)) + MINIMIYKOKO
        'Annetaan neliöille satunnaiset mitat MAKSIMIXKOKO ja MAKSIMIYKOKO muuttujien mukaan
        Neliot(i).X1 = (Rnd * (Form1.ScaleWidth - Neliot(i).leveys - 10))
        Neliot(i).Y1 = (Rnd * (Form1.ScaleHeight - Neliot(i).korkeus - 10))
        'Arvotaan Neliölle sattumanvaraiset paikat, vähintään 10 pikselin päähän reunasta
        If (OnlyResize = False) Then
            'Arvotaan myös väri ja neliön suunta
            Neliot(i).vari = RGB(Int(Rnd * 255), Int(Rnd * 255), Int(Rnd * 255))
            Neliot(i).xsuunta = YksiTaiMiinusYksi
            Neliot(i).ysuunta = YksiTaiMiinusYksi
        End If
    Next i
End Sub

Private Sub Piirra()
'Piirrä-aliohjelma, kutsutaan PiirraNelio-aliohjelmaa jokaisen neliön kohdalla
    Dim i As Integer
    Me.Cls 'putsataan ruutu
    For i = 0 To NELIOMAARA - 1
        Call PiirraNelio(Neliot(i).X1, Neliot(i).Y1, _
            Neliot(i).X1 + Neliot(i).leveys, Neliot(i).Y1 + Neliot(i).korkeus, Neliot(i).vari)
    Next i
    Me.Refresh 'kaikki piirretty, päivitetään ruutu
End Sub

Private Sub Liikuta()
'Liikuta-aliohjelma, tarkistetaan osuuko neliö seinään, jos osuu vaihdetaan suuntaa.
'Varmasti löytyy helpompikin tapa toteuttaa. :)

    Dim i As Integer, suhde As Double
    For i = 0 To NELIOMAARA - 1
        suhde = 1 - (Neliot(i).leveys / MAKSIMIXKOKO) * (Neliot(i).korkeus / MAKSIMIYKOKO)
        If (Neliot(i).xsuunta = 1) Then 'Ollaanko menossa oikealle
            If ((Neliot(i).X1 + Neliot(i).leveys) >= Form1.ScaleWidth) Then
            'Onko neliön oikeanpuoleinen sivu kiinni ruudun oikeassa reunassa, tai sen yli
                Neliot(i).xsuunta = -1 'Vaihdetaan x-suunta
                Neliot(i).X1 = Form1.ScaleWidth - Neliot(i).leveys - 1
                'Siirretään neliö kiinni ruudun oikeaan laitaan
            End If
        Else 'Ollaan menossa vasemmalle
            If ((Neliot(i).X1 <= 0)) Then 'Ollaanko vasemmassa laidassa, tai sen yli
                Neliot(i).xsuunta = 1 'Vaihdetaan x-suunta
                Neliot(i).X1 = 1 'Laitetaan neliö kiinni ruudun vasempaan laitaan
            End If
        End If

        If (Neliot(i).ysuunta = 1) Then 'Mennäänkö alaspäin
            If ((Neliot(i).Y1 + Neliot(i).korkeus) >= Form1.ScaleHeight) Then
            'Ollaanko alalaidassa kiinni, tai sen yli
                Neliot(i).ysuunta = -1 'Käännetään y-suunta
                Neliot(i).Y1 = Form1.ScaleHeight - Neliot(i).korkeus - 1
                'Laitetaan kiinni alalaitaan
            End If
        Else 'Ollaan menossa ylöspäin
            If ((Neliot(i).Y1 <= 0)) Then 'Ollaanko ylälaidassa, tai sen yli
                Neliot(i).ysuunta = 1 'Suunnaksi alaspäin
                Neliot(i).Y1 = 1 'Siirretään ruudun ylälaitaan
            End If
        End If

        Neliot(i).X1 = Neliot(i).X1 + (Neliot(i).xsuunta * suhde * MAKSIMIVAUHTI)
        Neliot(i).Y1 = Neliot(i).Y1 + (Neliot(i).ysuunta * suhde * MAKSIMIVAUHTI)
        'Ja lopuksi siirretään neliöitä eteenpäin:
        '   X-suunnan ja Y-Suunnan etumerkeistä on kiinni tuleeko muutoksesta miinus- vai pluspuolinen
        'Suhde-muuttuja kertoo kuinka iso neliö on verrattuna maksimikokoon:
        '   1.0 = Koko pienin mahdollinen, siis suurin mahdollinen vauhti
        '   0.0 = Koko suurin mahdollinen, täysin pysähtynyt
        '   jne..
    Next i
End Sub

Private Sub PaaLooppi()
'Päälooppi, pyöritetään Do While -looppia PAIVITYSVALI-muuttujan mukaisessa tahdissa,
'niin kauan kun Lopeta = false
    Dim timer As Long

    timer = GetTickCount()
    Do While (Lopeta = False)
        If PAIVITYSVALI < (GetTickCount() - timer) Then
        'Onko PAIVITYSVALI:n mukainen aika mennyt
            timer = GetTickCount() 'päivitetään timer
            Liikuta
            Piirra
        End If
        DoEvents
    Loop
End
End Sub

Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

'Fillrectin vaatima formaatti, sisältää neliön koordinaatit
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Public Sub PiirraNelio(X1 As Integer, Y1 As Integer, X2 As Integer, Y2 As Integer, color As Long)
'Piirtää neliön formiin

    Dim R As RECT, brush As Long
    brush = CreatePen(0, 5, color)
    'Luodaan pensseli: 0 = kiinteä pensseli, 5 = pensselin leveys
    SetRect R, X1, Y1, X2, Y2
    'Laitetaan piirrettävän neliön koordinaatit R-muuttujaan
    FillRect Form1.hdc, R, brush
    'Piirretään R:n määrittelemä neliö Form1:lle käyttäen aiemmin määriteltyä pensseliä
    Rectangle Form1.hdc, X1, Y1, X2, Y2
    'Piirretään neliölle reunat
    DeleteObject brush
    'Vapautetaan muistia poistamalla pensseli käytöstä
End Sub

Public Function YksiTaiMiinusYksi() As Integer
'Palauttaa sattumanvaraisesti joko 1 tai -1. Ei mikään elegantein toteutus :D
'Käytetään antamaan neliöille satunnaiset suunnat: 1 = mennään oikealle, -1 = vasemmalle
'Vastaavasti: 1 = mennään alaspäin, -1 = mennään ylöspäin

    Dim i As Integer
    Randomize
        i = (Rnd * 9) + 1
    If (i <= 5) Then
        YksiTaiMiinusYksi = -1
    Else
        YksiTaiMiinusYksi = 1
    End If
End Function