Keskustelu: Koodit: VB6: SetDIBits plasma

Option Explicit
Private Const leveys As Long = 640
Private Const korkeus As Long = 480
Private X As Long, Y As Long, i As Long, j As Long
Private Type paletti
 Punane As Byte
 Vihree As Byte
 Sinine As Byte
End Type
Private lasku As Long, lasku2 As Long, dumb As Single
Private liiku1 As Long
Private arvoo(1 To leveys * 4, 1 To korkeus * 4) As Long
Private aika As Long
Private Const pii As Long = 3 'jep, kolme.
Private Declare Function GetInputState Lib "user32" () As Long
Private Declare Function SetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Type BITMAP '14 tavua
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Type BITMAPINFOHEADER '40 tavua
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type
Private Const DIB_RGB_COLORS = 0&
Private Const BI_RGB = 0&

Private Sub plasma()
Dim varit(1 To 256) As paletti
Dim wid As Integer
Dim hgt As Integer
Dim bitmap_info As BITMAPINFO
Dim pixels() As Byte
Dim bytes_per_scanLine As Integer
Dim pad_per_scanLine As Integer

    'Otetaan bittikartan tietoja ylös, näistä ei kannata niin paljoa välittää :p
    wid = Picture1.ScaleWidth
    hgt = Picture1.ScaleHeight
    With bitmap_info.bmiHeader
        .biSize = 40
        .biWidth = wid
        ' Negatiivinen arvo = ylhäältä alas
        .biHeight = -hgt
        .biPlanes = 1
        .biBitCount = 32
        .biCompression = BI_RGB
        bytes_per_scanLine = ((((.biWidth * .biBitCount) + 31) \ 32) * 4)
        pad_per_scanLine = bytes_per_scanLine - (((.biWidth * .biBitCount) + 7) \ 8)
        .biSizeImage = bytes_per_scanLine * Abs(.biHeight)
    End With
    'luodaan oikean kokoinen rgb-kartta pikseleille
    ReDim pixels(1 To 4, 1 To wid, 1 To hgt)
Do
If GetInputState Then End
   aika = aika + 5
   dumb = aika * pii / 360
   lasku = leveys * 2 + 100 * Sin(dumb)
   lasku2 = korkeus * 2 + 100 * Cos(dumb)

    For i = 1 To 256
    With varit(i)
     .Punane = 72 + 71 * Cos(i * pii / 128 + aika / 74)
     .Sinine = 72 - 71 * Cos(i * pii / 128 + aika / 71)
     .Vihree = 72 + 71 * Sin(i * pii / 128 + aika / 64)
    End With
    Next i

    ' Muokataan pikseleitä
    For Y = 1 To korkeus
        For X = 1 To leveys
            liiku1 = arvoo(lasku + X, lasku2 + Y)
            If liiku1 > 255 Then liiku1 = 255
            pixels(3, X, Y) = varit(liiku1).Punane 'r
            pixels(2, X, Y) = varit(liiku1).Vihree 'g
            pixels(1, X, Y) = varit(liiku1).Sinine 'b
        Next X
    Next Y

    ' Näytetään muunneltu kuva
    SetDIBits Picture1.hdc, Picture1.Image, 0, hgt, pixels(1, 1, 1), bitmap_info, DIB_RGB_COLORS
    Picture1.Picture = Picture1.Image
Loop
End Sub

Private Sub Form_Load()
Me.ScaleMode = vbPixels
Picture1.AutoRedraw = False
Picture1.ScaleMode = vbPixels
Picture1.Width = 640
Picture1.Height = 480
Me.Width = 640 * 15
Me.Height = 480 * 15
Picture1.Left = 0
Picture1.Top = 0
Picture1.BorderStyle = 0
Me.Show
'luodaan palettikartta
For i = 1 To leveys * 4
For j = 1 To korkeus * 4
arvoo(i, j) = 64 + 63 * Sin(i / (90 + 10 * Cos(j / 74))) * Cos(j / (110 + 10 * Sin(i / 60)))
Next j
Next i
plasma
End Sub