Keskustelu: Koodit: VB6: Pyöreät linssit

Option Explicit

Private Sub Form_Load()
Dim I%, J%, Lupa As Boolean
For I = 0 To 5
  Do
    Sprite(I).X = Rand(pKuva.Width)
    Sprite(I).Y = Rand(pKuva.Height)
    Do
        Sprite(I).SX = (Rand(2) - 1) * Rand(3)
        Sprite(I).SY = (Rand(2) - 1) * Rand(3)
    Loop Until Sprite(I).SX <> 0 And Sprite(I).SY <> 0
    Sprite(I).Z = 1
    Sprite(I).On = True
    Sprite(I).Value = I
    Sprite(I).Mask = 0
    Sprite(I).Old = I
    Sprite(I).ScaleX = pSprite(I).ScaleWidth
    Sprite(I).ScaleY = pSprite(I).ScaleHeight
    Lupa = True
    'Asetetaan spritet kuvaan
    If I > 0 Then
        For J = 0 To 5
            If I <> J Then
            If OnkoTörmäys(Sprite(J).X, Sprite(J).Y, Sprite(I).X, Sprite(I).Y, Sprite(J).ScaleX, Sprite(J).ScaleY) Then
            Lupa = False
            End If
            End If
        Next J
    End If
  Loop Until Lupa
Next I
    Timer1.Enabled = True
End Sub

Private Sub Form_Unload(Cancel As Integer)
    End
End Sub

Private Sub Timer1_Timer()
Dim I%, J%
    Timer1.Enabled = False  ' Sammutetaan tämä ajastin
    For I = 0 To 5  ' käydään läpi Spritet 0 - 5
        Sprite(I).X = Sprite(I).X + Sprite(I).SX    ' Yksi askel X-suuntaan
        'Onko törmännyt toisiin?
        For J = 0 To 5
          If I <> J Then
            If OnkoTörmäys(Sprite(J).X, Sprite(J).Y, Sprite(I).X, Sprite(I).Y, Sprite(J).ScaleX, Sprite(J).ScaleY) Then
            'on törmäys, käännetään suunta
            Sprite(I).SX = -Sprite(I).SX
            Sprite(J).SX = -Sprite(J).SX
            Sprite(I).X = Sprite(I).X + Sprite(I).SX
            End If
          End If
        Next J
        'Onko mennyt ylos kuvan raunan? käännetään jos näin on
        If Sprite(I).X + Sprite(I).ScaleX > pKuva.Width + 12 Then Sprite(I).SX = -1: Sprite(I).X = Sprite(I).X - 1
        If Sprite(I).X - 16 < 0 Then Sprite(I).SX = 1: Sprite(I).X = Sprite(I).X + 1
        Sprite(I).Y = Sprite(I).Y + Sprite(I).SY
        'Onko spritet tärmänneet toisiinsa?
        For J = 0 To 5
            If J <> I Then
            If OnkoTörmäys(Sprite(J).X, Sprite(J).Y, Sprite(I).X, Sprite(I).Y, Sprite(J).ScaleX, Sprite(J).ScaleY) Then
            'on, käännetään suunta
            Sprite(I).SY = -Sprite(I).SY
            Sprite(J).SY = -Sprite(J).SY
            Sprite(I).Y = Sprite(I).Y + Sprite(I).SY
            End If
            End If
        Next J
        'Onko mennyt ylos kuvan raunan? käännetään jos näin on
        If Sprite(I).Y + Sprite(I).ScaleY > pKuva.Height + 12 Then Sprite(I).SY = -1: Sprite(I).Y = Sprite(I).Y - 1
        If Sprite(I).Y - 16 < 0 Then Sprite(I).SY = 1: Sprite(I).Y = Sprite(I).Y + 1
        'Piirretään kuvat
        PiirräLinssi Sprite(I)
    Next I
    'Kopioidaan valmis kuva
zz = BitBlt(PL!pKuva.hdc, 0, 0, PL!pKuva.ScaleWidth, PL!pKuva.ScaleHeight, F3!Buffer.hdc, 0, 0, vbSrcCopy)
    'Asetetaan Puskuriin alkuperäinen kuva reuraavaa piirtoa varten.
zz = BitBlt(F3!Buffer.hdc, 0, 0, PL!pKuva.ScaleWidth, PL!pKuva.ScaleHeight, F2!Buffer.hdc, 0, 0, vbSrcCopy)
    Timer1.Enabled = True
End Sub

Option Explicit

'Muuttujat
Public Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'näiden avulla sitten saadaankin jo parempi kuvanlaatu.
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal hStretchMode As Long) As Long
Const STRETCHMODE = vbPaletteModeNone

Type SpriteType  'Pelinapin yms. Muuttuja määrittely
    Value As Integer    ' Arvo
    On As Boolean       ' On/Off
    X As Integer        ' X-paikka ruudulla
    Y As Integer        ' Y-paikka
    Z As Integer        ' Z-paikka
    SX As Integer       ' Lisäyslaskuri
    SY As Integer
    Temp As Integer     ' Väliaikainen tieto
    'Kuvankäsittelyyn liittyvät muuttujat
    Old As Integer      ' Mikä spitren vanha kuva käytössä
    Mask As Integer     ' Mikä Spriten Maski käytössä
    ScaleX As Integer   ' Spriten X-koko
    ScaleY As Integer   ' Spriten Y-koko
End Type

Global Sprite(0 To 5) As SpriteType
Global zz&


Function Rand(R As Integer)
    Randomize Timer
    Rand = Int(Rnd(1) * R)
    DoEvents
End Function

Sub PiirräLinssi(I As SpriteType)
Dim J%
    J = I.Value
    zz = SetStretchBltMode(F2!Buffer.hdc, STRETCHMODE) ' Asetetaan venytys tilaan.
    'Otetaan suurennettava kohta
    zz = StretchBlt(PL!pSprite(J).hdc, 0, 0, 60, 60, F3!Buffer.hdc, I.X, I.Y, 48, 48, vbSrcCopy)
    'Pyöreä maski mustat reunat
    zz = BitBlt(PL!pSprite(J).hdc, 0, 0, 60, 60, PL!pMask(0).hdc, 0, 0, vbSrcAnd)

    'Kopioidaan alkuperäisestä neliö normaali koossa
    zz = BitBlt(PL!pSprite(J + 6).hdc, 0, 0, 60, 60, F2!Buffer.hdc, I.X - 12, I.Y - 12, vbSrcCopy)
    'Maskataan se :Pyöreä maski valkoiset reunat
    zz = BitBlt(PL!pSprite(J + 6).hdc, 0, 0, 60, 60, PL!pMask(1).hdc, 0, 0, vbSrcAnd)

    'Yhdistetään linssit, joka maskataan taustan kanssa.
    zz = BitBlt(PL!pSprite(J + 6).hdc, 0, 0, 60, 60, PL!pSprite(J).hdc, 0, 0, vbSrcPaint)
    'sijoitetaan se hieman ylä-vasemmalle
    zz = BitBlt(F3!Buffer.hdc, I.X - 12, I.Y - 12, 60, 60, PL!pSprite(J + 6).hdc, 0, 0, vbSrcCopy)
    PL!pSprite(J).Refresh
    PL!pSprite(J + 6).Refresh
End Sub

Function OnkoTörmäys(X1%, Y1%, X2%, Y2%, SX%, SY%) As Boolean
    If X1 + SX > X2 Then
        If X1 < X2 + SX Then
            If Y1 + SY > Y2 Then
                If Y1 < Y2 + SY Then
                    OnkoTörmäys = True
                End If
            End If

        End If
        End If
End Function