Date: 02-16-2022
Return to Index
created by gbSnippets
'Compilable Example: (Jose Includes)
'After compilation of this snippet to an EXE, you must manually change the
'extension to SCR and place the file in the \windows\system32 folder. It will
'then be visible from the Windows Display Properties application.
#Compiler PBWin 9, PBWin 10
#Compile EXE
#Dim All
%Unicode=1
#Include "win32api.inc"
#Resource "gbsnippets.pbr"
''========================================================================
''Change these as needed - specific to the screensaver
''========================================================================
Type SpriteInfo
w As Long 'width (of enclosing rectangle)
h As Long 'height (of enclosing rectangle)
x As Long 'x-position (upper-left corner)
y As Long 'y-position (upper-left corner)
sx As Long 'distance to move in x direction (speed)
sy As Long 'distance to move in y direction (speed)
frameMax As Long 'total number of available frames For the sprite
frameCurrent As Long 'current Frame #, the one to be displayed
waitMax As Long 'max wait count before changing frames
waitCount As Long 'current wait count (counts Timer Events)
hBMP as DWord 'image handle or arra index of sprite
' these next members are unique to realtime image drawing
Color1 as Long 'fill color
Color2 as Long 'pie fill color
End Type
Global Sprites() As SpriteInfo, canvasW as Long, canvasH as Long
Global MaxSprites as Long, MaxFrames as Long, hLst as DWord
Global SpriteH as Long, SpriteW as Long, SourceIsImages As Long, hWait as DWord
Global MoveTime$, DrawTime$, DisplayTime$, IntervalTime$, RandomImages As Long
Global UseBitStrings as Long, BitStrings() As String, bmpCanvas$, ShowTrails As Long
$Main_Title = "SCRNSAVE: Sprites:"
$Setting_Title = "Sprites Screensaver Settings"
$INIFileName = "sprite_screensaver.ini"
''========================================================================
''End of change section
''========================================================================
Global hDlg As DWord, hGraphic as DWord, hSettings as DWord
Global w,h,TimerInterval, OldProc As Long
%ID_Graphic = 600 : %ID_Timer = 700
Function PBMain() As Long
MaxSprites = 100 : TimerInterval = 20 : MaxFrames = 25
SpriteW = 32 : SpriteH = 32 : SourceIsImages = 1
RandomImages = 1 : UseBitStrings = 0
Dim Sprites(5000), BitStrings(5000) 'more than needed
Desktop Get Size To w,h
canvasW = w : canvasH = h
Dialog New Pixels, 0, $Main_Title,0,0,w,h, %WS_Popup To hDlg
Control Add Graphic, hDlg, %ID_Graphic, "", 0,0,w,h,%WS_Visible
Control Handle hDlg, %ID_Graphic to hGraphic
Graphic Attach hDlg, %ID_Graphic, Redraw
Graphic Color %Black, %RGB_PowderBlue
Graphic Font "MS Serif", 28, 1
Graphic Clear
Dialog Show Modal hDlg Call DlgProc
End Function
CallBack Function DlgProc() As Long
Select Case CB.Msg
Case %WM_InitDialog
Settings_INI "get"
SetWindowPos(hDlg, %HWND_TOPMOST, 0, 0, 0, 0, %SWP_NoMove Or %SWP_NoSize) 'on Top
InitializeGraphics
Select Case Left$(LCase$(Command$(1)),2)
Case "/p" : DisplayInPreviewWindow
Case "/s" : 'normal
Case "/a" : Dialog End hDlg 'set password - not used in this app, so just quit
Case "/c" : DisplaySettingsDialog : Dialog End hDlg 'settings, then quit
Case Else : 'nothing - start normally
End Select
OldProc = SetWindowLong(hGraphic, %GWL_WndProc, CodePTR(NewGraphicProc)) 'subclass
ShowCursor(%False)
SetTimer(CB.Hndl, %ID_Timer, TimerInterval, ByVal %NULL) 'uses callback messages
Dialog Post CB.Hndl, %WM_Timer, %ID_TIMER, 0 ' optional - forces an initial %WM_TIMER "event"
Case %WM_SetCursor
Static iCount as Long
Incr iCount
If iCount > 5 Then Dialog End hDlg
Case %WM_Timer
DrawSprites
MoveSprites
Graphic Redraw
Case %WM_Destroy
SetWindowLong hGraphic, %GWL_WNDPROC, OldProc 'un-subclass
ShowCursor(%True)
KillTimer CB.Hndl, %ID_Timer
Settings_INI "save"
End Select
End Function
Sub DisplaySettingsDialog()
Desktop Get Size To w,h
Dialog New Pixels, hDlg, $Setting_Title, (w-200)/2,(h-200)/2,200,200, %WS_SysMenu Or %WS_Caption Or %WS_ClipChildren To hSettings
Dialog Set Icon hSettings, "aainfo"
Control Add Label, hSettings, 800, "Timer Interval (ms):", 50, 60, 100, 20
Control Add TextBox, hSettings, 900, "20", 50, 80, 100, 20
Control Set Text hSettings, 900, Str$(TimerInterval)
Dialog Show Modal hSettings Call SettingsProc
End Sub
CallBack Function SettingsProc() As Long
Local temp$
Select Case CB.Msg
Case %WM_Command
If CB.Ctl = %IDOK Then Dialog End hSettings
If CB.Ctl = %IDCANCEL Then Dialog End hSettings
Case %WM_Destroy
Control Get Text hSettings, 900 To temp$
TimerInterval = Val(temp$)
If TimerInterval <=0 Then TimerInterval = 1
Settings_INI "save"
End Select
End Function
Sub Settings_INI(Task$)
Local temp As Asciiz*%Max_Path, INIFileName As Asciiz*%Max_Path
'defines file name (any file name will work)
INIFileName = Exe.Path$ + $INIFileName
If Task$ = "get" Then
'get value for numeric variable
Getprivateprofilestring "Settings", "TimerInterval", "20", temp, %Max_Path, INIFileName
TimerInterval = Val(temp)
End If
If Task$ = "save" Then
'save numeric variable
temp = Str$(TimerInterval)
WritePrivateProfileString "Settings", "TimerInterval", temp, INIFileName
End If
End Sub
Function NewGraphicProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case Msg
Case %WM_Char
Dialog End hDlg
End Select
Function = CallWindowProc(OldProc, hWnd, Msg, wParam, lParam)
End Function
Sub DisplayInPreviewWindow
'not supported as this time. this Sub is a placeholder for when the
'Display Properties calls the screensaver with the /p preview mode command.
Dialog End hDlg 'not supported at this time
Exit Sub
' The following code does not work. I found this in some VB6 examples,
' but haven't gotten it to work in PowerBASIC so far. Basically, the
' code is supposed to set the screensaver dialog as a child of the
' Preview Window so that the screensaver will play in that smaller window.
' I included it here in case anyone feels the urge to play with it.
Local lngStyle As Long, dispHWND As Long, DispRec As RECT, temp$
temp$ = Command$(1)
Replace "/p" With "" in temp$
dispHWND = Val(Trim$(temp$))
GetClientRect dispHWND, DispRec
lngStyle = GetWindowLong(hDlg, %GWL_STYLE)
lngStyle = lngStyle Or %WS_CHILD 'Append "WS_CHILD"
SetWindowLong hDlg, %GWL_STYLE, lngStyle
SetParent hDlg, dispHWND
SetWindowLong hDlg, %GWL_HWNDPARENT, dispHWND
SetWindowPos hDlg, %HWND_TOP, 0&, 0&, _
DispRec.nRight, DispRec.nBottom, _
%SWP_NOZORDER Or %SWP_NOACTIVATE Or %SWP_SHOWWINDOW
End Sub
Sub DrawSprites
Local i as Long, arcStart as Single, arcEnd as Single
Local p as Long Pointer, pStart as Long, s as Long Pointer
Local x as Long, y as Long, sStart as Long
Graphic Attach hDlg, %ID_Graphic, Redraw
If ShowTrails = 0 Then Graphic Clear
If UseBitStrings Then
Graphic Get Bits To bmpCanvas$
p = StrPTR(bmpCanvas$)+8
pStart = p
End If
If SourceIsImages Then
For i = 0 to MaxSprites
If UseBitStrings Then
s = StrPTR(BitStrings(i))+8
sStart = s
' For y = 0 to Sprites(i).h-1
' p = pStart + y*CanvasW*4 + Sprites(i).y*CanvasW*4 + Sprites(i).x*4
' For x = 0 to Sprites(i).w-1
' @p = @s : Incr s : Incr p
' Next x
' Next y
' Graphic Set Bits bmpCanvas$
Else
Graphic Copy Sprites(i).hBMP, 0 To (Sprites(i).x, Sprites(i).y)
End If
Next i
Else
For i = 0 to MaxSprites
Graphic Ellipse (Sprites(i).x, Sprites(i).y)-(Sprites(i).x + Sprites(i).w, Sprites(i).y + Sprites(i).h), %Black, Sprites(i).Color1
arcStart = (Sprites(i).frameCurrent) * 6.28 / Sprites(i).frameMax
arcEnd = (Sprites(i).frameCurrent + 10) * 6.28 / Sprites(i).frameMax
Graphic Pie (Sprites(i).x, Sprites(i).y)-(Sprites(i).x + Sprites(i).w, Sprites(i).y + Sprites(i).h), _
ArcStart, ArcEnd, %Black, Sprites(i).Color2
Next i
End If
End Sub
Sub MoveSprites
Local i As Long
For i = 0 To MaxSprites
Sprites(i).x = Sprites(i).x + Sprites(i).sx
Sprites(i).y = Sprites(i).y + Sprites(i).sy
If Sprites(i).x < 0 Then
Sprites(i).x = 0
Sprites(i).sx = -1 * Sprites(i).sx
ElseIf Sprites(i).x + Sprites(i).w > canvasW Then
Sprites(i).x = canvasW - Sprites(i).w
Sprites(i).sx = -1 * Sprites(i).sx
End If
If Sprites(i).y < 0 Then
Sprites(i).y = 0
Sprites(i).sy = -1 * Sprites(i).sy
ElseIf Sprites(i).y + Sprites(i).h > canvasH Then
Sprites(i).y = canvasH - Sprites(i).h
Sprites(i).sy = -1 * Sprites(i).sy
End If
Incr Sprites(i).waitCount
If Sprites(i).waitCount = Sprites(i).waitMax Then
Sprites(i).waitCount = 0
Sprites(i).frameCurrent = (Sprites(i).frameCurrent + 1) Mod Sprites(i).frameMax
End If
Next i
End Sub
Sub InitializeGraphics
Local i as Long
ImageList New Icon 32, 32, 24, 100 To hLst 'create imagelist w,h,depth,size
For i = 1 To 100
ImageList Add Icon hLst, "mos" + Format$(i,"000")
Next i
IntervalTime$ = Format$(1000/TimerInterval,"###0")
Local j as Long, hBMP as DWord
Graphic Bitmap New 32,32 To hBMP 'for use whenver random 32x32 icons images are used from *.PBR
Randomize
For i = 0 To MaxSprites
Sprites(i).w = SpriteW
Sprites(i).h = SpriteH
Sprites(i).x = Rnd(0,canvasW-Sprites(i).w)
Sprites(i).y = Rnd(0,canvasH-Sprites(i).h)
Sprites(i).sx = Rnd(2,3)*((-1)^Rnd(1,2))
Sprites(i).sy = Rnd(2,3)*((-1)^Rnd(1,2))
Sprites(i).frameMax = MaxFrames
Sprites(i).frameCurrent = Rnd(0,Sprites(i).frameMax)
Sprites(i).waitMax = 1 'Rnd(1,3)
Sprites(i).waitCount = 0
Sprites(i).Color1 = Rgb(Rnd(0,256), Rnd(0,256), Rnd(0,256)) 'Rnd(0,4000000000)
Sprites(i).Color2 = Rgb(Rnd(0,256), Rnd(0,256), Rnd(0,256)) 'Rnd(0,4000000000)
If Sprites(i).hBMP Then
Graphic Attach Sprites(i).hBMP, 0 : Graphic Bitmap End
End If
If SourceIsImages Then
If RandomImages Then
Graphic Attach hBMP,0
Graphic ImageList (0,0), hLst, Rnd(1,100) ,0,%ILD_Normal
Graphic Bitmap New Sprites(i).w, Sprites(i).h To Sprites(i).hBMP
Graphic Attach Sprites(i).hBMP, 0
Graphic Stretch hBMP, 0, (0,0)-(32,32) To (0,0)-(Sprites(i).w,Sprites(i).h)
Else
Graphic Bitmap Load "cowgirl", Sprites(i).w, Sprites(i).h, %HalfTone To Sprites(i).hBMP
End If
If UseBitStrings Then
Graphic Attach Sprites(i).hBMP, 0
Graphic Get Bits To BitStrings(i)
Graphic Bitmap End
Sprites(i).hBMP = 0
End If
Else
Sprites(i).hBMP = 0
End If
Next i
If hWait Then Dialog End hWait
End Sub
'gbs_00478
'Date: 03-10-2012
http://www.garybeene.com/sw/gbsnippets.htm