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 '------------------------------------------------------------