You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
351 lines
18 KiB
351 lines
18 KiB
Attribute VB_Name = "mSSaver"
|
|
Option Explicit
|
|
|
|
Public DisplayHwnd As Long ' Hwnd of display form
|
|
Public DispRec As RECT ' Rectangle values of display form
|
|
Public PrevWndProc As Long ' Previous window proc (used in subclassing)
|
|
Public RunMode As Long ' Screen saver running mode (run, preview, setup)
|
|
Public DeskBmp As BITMAP ' Bitmap copy of the desktop
|
|
Public DeskDC As Long ' Desktop device context handle
|
|
|
|
'-----------------------------------------------------------------
|
|
Sub Main()
|
|
'-----------------------------------------------------------------
|
|
Dim rc As Long ' function return code
|
|
Dim cmd As String ' command line arguments
|
|
Dim Style As Long ' window style of display form
|
|
'-----------------------------------------------------------------
|
|
If App.PrevInstance Then End ' Already have one instance running, end program!
|
|
''' Set gSpriteCollection = New Collection ' Create new sprite collection
|
|
|
|
cmd = LCase$(Trim$(Command$)) ' copy command line parameters in lowercase...
|
|
|
|
Select Case Mid$(cmd, 1, 2) ' Parse 1st 2 chars from cmd line
|
|
'------------------------------------------------------------
|
|
Case "", "/s" '[Normal Run Mode] Run as Screen Saver on desktop.
|
|
'------------------------------------------------------------
|
|
RunMode = RM_NORMAL ' Store screen saver's run mode
|
|
|
|
GetWindowRect GetDesktopWindow(), DispRec ' Get DeskTop Rectangle dimentions
|
|
|
|
Load frmSSaver ' Load Screen saver
|
|
#If DebugOn Then ' Do this only when debugging
|
|
frmSSaver.Show
|
|
#Else ' Do this only when NOT debugging
|
|
SetWindowPos frmSSaver.hwnd, _
|
|
HWND_TOPMOST, 0&, 0&, DispRec.Right, DispRec.Bottom, _
|
|
SWP_SHOWWINDOW ' Size window and make top most
|
|
#End If
|
|
'------------------------------------------------------------
|
|
Case "/p" '[Win 95 & NT 4 Preview Mode] Run inside of the Screen Saver Config Viewer.
|
|
'------------------------------------------------------------
|
|
'- Run the screen saver in the windows preview dialog, YES in VB!
|
|
'------------------------------------------------------------
|
|
RunMode = RM_PREVIEW ' Store screen saver's run mode...
|
|
|
|
DisplayHwnd = GetHwndFromCmd(cmd) ' ** Get HWND of Preview DeskTop
|
|
GetClientRect DisplayHwnd, DispRec ' Get Display Rectangle dimentions
|
|
|
|
Load frmSSaver ' Load Screen saver form
|
|
frmSSaver.Caption = "Preview" ' Consistant with Win 95 screen savers(what the heck)
|
|
|
|
Style = GetWindowLong(frmSSaver.hwnd, GWL_STYLE) ' ** Get current window style
|
|
Style = Style Or WS_CHILD ' ** Append "WS_CHILD" style to the hWnd window style
|
|
SetWindowLong frmSSaver.hwnd, GWL_STYLE, Style ' ** Add new style to window
|
|
|
|
SetParent frmSSaver.hwnd, DisplayHwnd ' ** Set preview window as parent window
|
|
SetWindowLong frmSSaver.hwnd, GWL_HWNDPARENT, DisplayHwnd ' ** Save the hWnd Parent in hWnd's window struct.
|
|
|
|
' ** Show screensaver in the preview window...
|
|
SetWindowPos frmSSaver.hwnd, _
|
|
HWND_TOP, 0&, 0&, DispRec.Right, DispRec.Bottom, _
|
|
SWP_NOZORDER Or SWP_NOACTIVATE Or SWP_SHOWWINDOW
|
|
'------------------------------------------------------------
|
|
' lines prefixed with ** are necessary for the preview dialog to work correctly.
|
|
'------------------------------------------------------------
|
|
Case "/c" '[ScreenSaver Configuration Mode] Run Screen Saver Settings Dialog.
|
|
'------------------------------------------------------------
|
|
Load frmSSetup ' Load screensaver setup dialog
|
|
frmSSetup.Show vbModeless ' Show setup dialog
|
|
'------------------------------------------------------------
|
|
Case Else
|
|
'------------------------------------------------------------
|
|
#If DebugOn Then ' Do this only when debugging
|
|
MsgBox "Unknown Command Line Param: [" & Command$ & "]" ' Debug/display unknown param...
|
|
#End If
|
|
End Select
|
|
'-----------------------------------------------------------------
|
|
End Sub
|
|
'-----------------------------------------------------------------
|
|
|
|
'------------------------------------------------------------
|
|
Public Function SubWndProc(ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
|
|
'------------------------------------------------------------
|
|
'- Subclassing not implemented but reservered for furture use...
|
|
'------------------------------------------------------------
|
|
' Select Case MSG
|
|
' Case WM_PAINT
|
|
' SubWndProc = CallWindowProc(PrevWndProc, hwnd, MSG, wParam, lParam)
|
|
' PaintDeskDC DeskDC, DeskBmp, hwnd
|
|
' Exit Function
|
|
' End Select
|
|
|
|
' SubWndProc = CallWindowProc(PrevWndProc, hwnd, MSG, wParam, lParam)
|
|
'------------------------------------------------------------
|
|
End Function
|
|
'------------------------------------------------------------
|
|
|
|
'-----------------------------------------------------------------
|
|
Private Function GetHwndFromCmd(cmd As String) As Long
|
|
'-----------------------------------------------------------------
|
|
Dim Str As String ' substring variable
|
|
Dim lenStr As Long ' length of substring
|
|
Dim Idx As Long ' Index variable
|
|
'-----------------------------------------------------------------
|
|
Str = Trim$(cmd) ' copy command line
|
|
lenStr = Len(Str) ' get size of string
|
|
|
|
For Idx = lenStr To 1 Step -1 ' for each char in string
|
|
Str = Right$(Str, Idx) ' chop off the rightmost char
|
|
If IsNumeric(Str) Then ' if substring is numeric then value is an hWnd
|
|
GetHwndFromCmd = Val(Str) ' return hWnd value
|
|
Exit For ' exit for loop
|
|
End If
|
|
Next
|
|
'-----------------------------------------------------------------
|
|
End Function
|
|
'-----------------------------------------------------------------
|
|
|
|
'-----------------------------------------------------------------
|
|
Public Sub AboutBox(hwnd As Long)
|
|
'-----------------------------------------------------------------
|
|
' Show help about dialog...
|
|
ShellAbout hwnd, "Visual Basic 5.0 - Screen Saver...", _
|
|
vbCrLf & "Building Applications in Visual Basic 5.0", 0
|
|
'-----------------------------------------------------------------
|
|
End Sub
|
|
'-----------------------------------------------------------------
|
|
|
|
'-----------------------------------------------------------------
|
|
Private Sub AssertRC(bool As Boolean, rc As Long, fcnName As String)
|
|
'-----------------------------------------------------------------
|
|
#If DebugOn Then
|
|
If Not bool Then
|
|
MsgBox "Assertion Failed::" & vbCrLf & _
|
|
" In Module:: " & fcnName & vbCrLf & _
|
|
" Return Code:: " & CStr(rc), vbCritical
|
|
End If
|
|
#End If
|
|
'-----------------------------------------------------------------
|
|
End Sub
|
|
'-----------------------------------------------------------------
|
|
|
|
'------------------------------------------------------------
|
|
Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, ByRef KeyVal As String) As Boolean
|
|
'------------------------------------------------------------
|
|
Dim i As Long ' Loop Counter
|
|
Dim rc As Long ' Return Code
|
|
Dim hKey As Long ' Handle To An Open Registry Key
|
|
Dim hDepth As Long '
|
|
Dim KeyValType As Long ' Data Type Of A Registry Key
|
|
Dim tmpVal As String ' Tempory Storage For A Registry Key Value
|
|
Dim KeyValSize As Long ' Size Of Registry Key Variable
|
|
'------------------------------------------------------------
|
|
' Open RegKey Under KeyRoot {HKEY_LOCAL_MACHINE...}
|
|
'------------------------------------------------------------
|
|
rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' Open Registry Key
|
|
|
|
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Handle Error...
|
|
|
|
tmpVal = String$(1024, 0) ' Allocate Variable Space
|
|
KeyValSize = 1024 ' Mark Variable Size
|
|
|
|
'------------------------------------------------------------
|
|
' Retrieve Registry Key Value...
|
|
'------------------------------------------------------------
|
|
rc = RegQueryValueEx(hKey, SubKeyRef, 0, _
|
|
KeyValType, tmpVal, KeyValSize) ' Get/Create Key Value
|
|
|
|
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Handle Errors
|
|
|
|
If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then ' Win95 Adds Null Terminated String...
|
|
tmpVal = Left(tmpVal, KeyValSize - 1) ' Null Found, Extract From String
|
|
Else ' WinNT Does NOT Null Terminate String...
|
|
tmpVal = Left(tmpVal, KeyValSize) ' Null Not Found, Extract String Only
|
|
End If
|
|
'------------------------------------------------------------
|
|
' Determine Key Value Type For Conversion...
|
|
'------------------------------------------------------------
|
|
Select Case KeyValType ' Search Data Types...
|
|
Case REG_SZ ' String Registry Key Data Type
|
|
KeyVal = tmpVal ' Copy String Value
|
|
Case REG_DWORD ' Double Word Registry Key Data Type
|
|
For i = Len(tmpVal) To 1 Step -1 ' Convert Each Bit
|
|
KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1))) ' Build Value Char. By Char.
|
|
Next
|
|
KeyVal = Format$("&h" + KeyVal) ' Convert Double Word To String
|
|
End Select
|
|
|
|
GetKeyValue = True ' Return Success
|
|
rc = RegCloseKey(hKey) ' Close Registry Key
|
|
Exit Function ' Exit
|
|
'------------------------------------------------------------
|
|
GetKeyError: ' Cleanup After An Error Has Occured...
|
|
'------------------------------------------------------------
|
|
KeyVal = "" ' Set Return Val To Empty String
|
|
GetKeyValue = False ' Return Failure
|
|
rc = RegCloseKey(hKey) ' Close Registry Key
|
|
'------------------------------------------------------------
|
|
End Function
|
|
'------------------------------------------------------------
|
|
|
|
'------------------------------------------------------------
|
|
Public Function UpdateKey(KeyRoot As Long, KeyName As String, SubKeyName As String, SubKeyValue As String) As Boolean
|
|
'------------------------------------------------------------
|
|
Dim rc As Long ' Return Code
|
|
Dim hKey As Long ' Handle To A Registry Key
|
|
Dim hDepth As Long '
|
|
Dim lpAttr As SECURITY_ATTRIBUTES ' Registry Security Type
|
|
'------------------------------------------------------------
|
|
lpAttr.nLength = 50 ' Set Security Attributes To Defaults...
|
|
lpAttr.lpSecurityDescriptor = 0 ' ...
|
|
lpAttr.bInheritHandle = True ' ...
|
|
|
|
'------------------------------------------------------------
|
|
'- Create/Open Registry Key...
|
|
'------------------------------------------------------------
|
|
rc = RegCreateKeyEx(KeyRoot, KeyName, _
|
|
0, REG_SZ, _
|
|
REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, lpAttr, _
|
|
hKey, hDepth) ' Create/Open //KeyRoot//KeyName
|
|
|
|
If (rc <> ERROR_SUCCESS) Then GoTo CreateKeyError ' Handle Errors...
|
|
|
|
'------------------------------------------------------------
|
|
'- Create/Modify Key Value...
|
|
'------------------------------------------------------------
|
|
If (SubKeyValue = "") Then SubKeyValue = " " ' A Space Is Needed For RegSetValueEx() To Work...
|
|
|
|
rc = RegSetValueEx(hKey, SubKeyName, _
|
|
0, REG_SZ, _
|
|
SubKeyValue, Len(SubKeyValue)) ' Create/Modify Key Value
|
|
|
|
If (rc <> ERROR_SUCCESS) Then GoTo CreateKeyError ' Handle Error
|
|
'------------------------------------------------------------
|
|
'- Close Registry Key...
|
|
'------------------------------------------------------------
|
|
rc = RegCloseKey(hKey) ' Close Key
|
|
|
|
UpdateKey = True ' Return Success
|
|
Exit Function ' Exit
|
|
'------------------------------------------------------------
|
|
CreateKeyError:
|
|
'------------------------------------------------------------
|
|
UpdateKey = False ' Set Error Return Code
|
|
rc = RegCloseKey(hKey) ' Attempt To Close Key
|
|
'------------------------------------------------------------
|
|
End Function
|
|
'------------------------------------------------------------
|
|
|
|
'------------------------------------------------------------
|
|
Public Sub SaveSettings()
|
|
'------------------------------------------------------------
|
|
Dim RegVal As String ' String value of registry key
|
|
Dim lRegVal As Long ' long value of registry key
|
|
'------------------------------------------------------------
|
|
' Save Sprite Count Value
|
|
RegVal = CStr(gSpriteCount)
|
|
Call UpdateKey(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_SPRITECOUNT, RegVal)
|
|
|
|
' Save Tracers on Value
|
|
RegVal = sFALSE
|
|
If gTracers Then RegVal = sTRUE
|
|
Call UpdateKey(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_TRACERSON, RegVal)
|
|
|
|
' Save Refresh Rate Value
|
|
RegVal = CStr(gRefreshRate)
|
|
Call UpdateKey(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_REFRESHRATE, RegVal)
|
|
|
|
' Save Rate Random Value
|
|
RegVal = sFALSE
|
|
If gRefreshRND Then RegVal = sTRUE
|
|
Call UpdateKey(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_RATERANDOM, RegVal)
|
|
|
|
' Save Sprite Size Value
|
|
RegVal = CStr(gSpriteSize)
|
|
Call UpdateKey(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_SPRITESIZE, RegVal)
|
|
|
|
' Save Size Random Value
|
|
RegVal = sFALSE
|
|
If gSizeRND Then RegVal = sTRUE
|
|
Call UpdateKey(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_SIZERANDOM, RegVal)
|
|
|
|
' Save Sprite Speed Value
|
|
RegVal = CStr(gSpriteSpeed)
|
|
Call UpdateKey(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_SPRITESPEED, RegVal)
|
|
|
|
' Save Speed Random Value
|
|
RegVal = sFALSE
|
|
If gSpeedRND Then RegVal = sTRUE
|
|
Call UpdateKey(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_SPEEDRANDOM, RegVal)
|
|
'------------------------------------------------------------
|
|
End Sub
|
|
'------------------------------------------------------------
|
|
|
|
'------------------------------------------------------------
|
|
Public Sub LoadSettings()
|
|
'------------------------------------------------------------
|
|
Dim RegVal As String
|
|
Dim iRegVal As Long
|
|
'------------------------------------------------------------
|
|
' Get Sprite Count Value
|
|
RegVal = ""
|
|
Call GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_SPRITECOUNT, RegVal)
|
|
gSpriteCount = Val(RegVal)
|
|
If (gSpriteCount < MIN_SPRITECOUNT) Then gSpriteCount = DEF_SPRITECOUNT ' Default value.
|
|
If (gSpriteCount > MAX_SPRITECOUNT) Then gSpriteCount = MAX_SPRITECOUNT
|
|
|
|
' Get Tracers on Value
|
|
RegVal = ""
|
|
Call GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_TRACERSON, RegVal)
|
|
gTracers = (RegVal = sTRUE)
|
|
|
|
' Get Refresh Rate Value
|
|
RegVal = ""
|
|
Call GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_REFRESHRATE, RegVal)
|
|
gRefreshRate = Val(RegVal)
|
|
If (gRefreshRate < MIN_REFRESHRATE) Then gRefreshRate = MAX_REFRESHRATE ' Default value ...fast
|
|
If (gRefreshRate > MAX_REFRESHRATE) Then gRefreshRate = MAX_REFRESHRATE
|
|
|
|
' Get Rate Random Value
|
|
RegVal = ""
|
|
Call GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_RATERANDOM, RegVal)
|
|
gRefreshRND = (RegVal = sTRUE)
|
|
|
|
' Get Sprite Size Value
|
|
RegVal = ""
|
|
Call GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_SPRITESIZE, RegVal)
|
|
gSpriteSize = Val(RegVal)
|
|
If (gSpriteSize < MIN_SPRITESIZE) Then gSpriteSize = MIN_SPRITESIZE
|
|
If (gSpriteSize > MAX_SPRITESIZE) Then gSpriteSize = MAX_SPRITESIZE
|
|
|
|
' Get Size Random Value
|
|
RegVal = ""
|
|
Call GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_SIZERANDOM, RegVal)
|
|
gSizeRND = (RegVal = sTRUE) Or (RegVal = "") ' Default to TRUE
|
|
|
|
' Get Sprite Speed Value
|
|
RegVal = ""
|
|
Call GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_SPRITESPEED, RegVal)
|
|
gSpriteSpeed = Val(RegVal)
|
|
If (gSpriteSpeed < MIN_SPRITESPEED) Then gSpriteSpeed = MIN_SPRITESPEED
|
|
If (gSpriteSpeed > MAX_SPRITESPEED) Then gSpriteSpeed = MAX_SPRITESPEED
|
|
|
|
' Get Speed Random Value
|
|
RegVal = ""
|
|
Call GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_SPEEDRANDOM, RegVal)
|
|
gSpeedRND = (RegVal = sTRUE)
|
|
'------------------------------------------------------------
|
|
End Sub
|
|
'------------------------------------------------------------
|