by DmkWare (1 Submission)
Category: Graphics
Compatability: Visual Basic 5.0
Difficulty: Unknown Difficulty
Originally Published: Sun 24th October 1999
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Crystalize. This can be turned into a screen saver fast. Simple yet complicated.
VBcoders
'Title: Crystalize
'Coded By: Dave Katrowski.
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Dim bRunning As Boolean 'Running?
Dim iMainX As Integer, iMainY As Integer 'Main Coordinates
Dim iColorOp As Integer 'Render Color Option (1 - 10)
Dim FRMHDC As Long 'Var For Forms DC
Const O_Top = 1 'Hit Bottom Side Come Out Top
Const O_Right = 2 'Hit Left Side Come Out Right
Const O_Bottom = 3 'Hit Bottom Side Come Out Top
Const O_Left = 4 'Hit Right Side Come Out Left
Const Max_Score = 5 'See DoPixelTest
Sub Init()
Randomize 'Initializes the random-number generator
iColorOp = Int(Rnd * 10) 'Choose Random Color Option
bRunning = True 'Running?... uh-huh.
iMainX = Int(Rnd * Form1.ScaleHeight) 'Pick a random X value
iMainY = Int(Rnd * Form1.ScaleWidth) 'Pick a random Y value
Form1.AutoRedraw = True 'Does this need a comment?
Form1.ScaleMode = 3 '3 = Pixel
Form1.BackColor = &H0 'Set Back Color to Black
FRMHDC = GetDC(Form1.hwnd) 'Grab the forms DC
Form1.Show 'Make sure the form shows up...
End Sub
Sub InitOpposite(iOption As Integer)
Select Case iOption
Case O_Top 'Hit Bottom Side Come Out Top
iMainY = 0
Case O_Bottom 'Hit Top Side Come Out Bottom
iMainY = Form1.ScaleHeight - 1
Case O_Left 'Hit Right Side Come Out Left
iMainX = Form1.ScaleWidth - 1
Case O_Right 'Hit Left Side Come Out Right
iMainX = 0
End Select
End Sub
Function FindColor(ColorOption As Integer)
Select Case ColorOption
Case 1
FindColor = RndColor_Red 'See RndColor_Red
Case 2
FindColor = RndColor_Green 'See RndColor_Green
Case 3
FindColor = RndColor_Blue 'See RndColor_Blue
Case 4
FindColor = RndColor_Gray 'See RndColor_Gray
Case 5
FindColor = RndColor_Cyan 'See RndColor_Cyan
Case 6
FindColor = RndColor_Yellow 'See RndColor_Yellow
Case 7
FindColor = RndColor_Fire 'See RndColor_Fire
Case 8
FindColor = RndColor_DrkGreen 'See RndColor_DrkGreen
Case 9
FindColor = RndColor_Ice 'See RndColor_Ice
Case Else 'Everything on the Palette
FindColor = Rnd * &HFFFFFF
End Select
End Function
Function DoPixelTest()
'Test 5 Random Pixels For Color.
'If None are Black, Clear the
'form and Start over...
Static TestScore As Integer, ColorCheck As Long 'Temporary Vars
TestScore = 0
For i = 1 To Max_Score
VBA.Interaction.DoEvents
' \/ Grab Color of Random Pixel \/
ColorCheck = GetPixel(FRMHDC, Int(Rnd * Form1.ScaleWidth), Int(Rnd * Form1.ScaleHeight))
' \/ If the color isn't black add to the score \/
If Not ColorCheck = &H0 Then TestScore = TestScore + 1
Next
' \/ Report Grade \/
If TestScore = Max_Score Then Form1.Cls: Init
End Function
Function FindNext()
iMainX = RndRange(iMainX - 2, iMainX + 2) 'See RndRange
iMainY = RndRange(iMainY - 2, iMainY + 2)
' \/ Test for Wall Collision \/
If iMainX > Form1.ScaleWidth Then InitOpposite O_Right
If iMainX < 0 Then InitOpposite O_Left
If iMainY > Form1.ScaleHeight Then InitOpposite O_Top
If iMainY < 0 Then InitOpposite O_Bottom
End Function
Sub RenderResults() 'Render
Call SetPixel(FRMHDC, iMainX, iMainY, FindColor(iColorOp))
End Sub
Public Function RndRange(ByVal intMin As Integer, ByVal intMax As Integer)
'This Function Generates a Random number between 2 numbers.
RndRange = Int(Rnd * (intMax - intMin + 1)) + intMin
End Function
Public Function RndColor_Red() 'Random Black to Red
RndColor_Red = Rnd * &HFF
End Function
Public Function RndColor_Green() 'Random Black to Green
RndColor_Green = RGB(0, Int(Rnd * 255), 0)
End Function
Public Function RndColor_DrkGreen() 'Random Black to DarkGreen
RndColor_DrkGreen = RGB(0, Int(Rnd * 150), 0)
End Function
Public Function RndColor_Blue() 'Random Black to Blue
RndColor_Blue = RGB(0, 0, Int(Rnd * 255))
End Function
Public Function RndColor_Gray() 'Random Black to White
Static GShade As Integer
GShade = Int(Rnd * 255)
RndColor_Gray = RGB(GShade, GShade, GShade)
End Function
Public Function RndColor_Fire() 'Random Red & Green
RndColor_Fire = RGB(Int(Rnd * 255), Int(Rnd * 255), 0)
End Function
Public Function RndColor_Yellow() 'Random Black to Yellow
Static GShade As Integer
GShade = Int(Rnd * 255)
RndColor_Yellow = RGB(GShade, GShade, 0)
End Function
Public Function RndColor_Ice() 'Random Green & Blue
RndColor_Ice = RGB(0, Int(Rnd * 255), Int(Rnd * 255))
End Function
Public Function RndColor_Cyan() 'Random Black to Cyan
Static GShade As Integer 'Similar to ICE
GShade = Int(Rnd * 255)
RndColor_Cyan = RGB(0, GShade, GShade)
End Function
Private Sub Form_Load()
Init 'Initialize Everything
Do While bRunning = True 'Loop
VBA.Interaction.DoEvents
FindNext 'See FindNext
RenderResults 'See RenderResults
DoPixelTest 'See DoPixelTest
Loop
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
Unload Me 'Unload on LeftClick
Else
Form1.Cls: Init 'Restart on RightClick
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
bRunning = False 'End Loop
End 'Terminate Application
End Sub
No comments have been posted about Crystalize. This can be turned into a screen saver fast. Simple yet complicated.. Why not be the first to post a comment about Crystalize. This can be turned into a screen saver fast. Simple yet complicated..
