' ---------------------------------------------------------------------
' Begin: From frmScreenSaver

'This is the screen saver itself.  Because all of the screen saver code
' is in mod/clsScreenSaver, this is just concerned with what to draw on
' the screen while it's displayed.  A couple of notes however.  First,
' this form should have the following properties set:
'
'  BorderStyle = 0 - None
'  BackColor = (Black)
'  KeyPreview = True
'
' Also, you're responsible for tracking the mouse cursor in any child
' controls.  Ideally, just put the following in any of the child's
' _MouseMove events:
'
'     PostMessage Me.hwnd, WM_MOUSEMOVE, 0, 0
'
'  From there the framework will close the screensaver if necessary
'
'  Finally, make sure and set the start up to Sub Main()

Option Explicit

Private Sub Form_Paint()
    'Just draw a stupid 'X' on the form to verify it's size and
    ' and position both full screen and in the display
    ' properties dialog.

    Line (0, 0)-(Width, Height), vbWhite
    Line (Width, 0)-(0, Height), vbWhite

End Sub

' End: From frmScreenSaver
' ---------------------------------------------------------------------

' ---------------------------------------------------------------------
' Begin: Module modScreenSaver

Option Explicit

'Mutex name to prevent multiple versions
Public Const MUTEX_NAME = "Scott's Screen Saver Mutex"

'ID of timer to dismiss password window after 30 seconds
Public Const TIMER_ID = 10

'Windows API
Type POINTAPI
    X As Long
    Y As Long
End Type

Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type

Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal _
        hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, _
        ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As _
        Long
Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal _
        hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal _
        lParam As Long) As Long
Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
Declare Function GetTickCount Lib "kernel32" () As Long
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _
        (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As _
        Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
        (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As _
        Long) As Long
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
        (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal _
        hWndNewParent As Long) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect _
        As RECT) As Long
Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexA" _
        (lpMutexAttributes As Any, ByVal bInitialOwner As Long, ByVal _
        lpName As String) As Long
Declare Function ReleaseMutex Lib "kernel32" (ByVal hMutex As Long) As _
        Long
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As _
        Long
Declare Function PwdChangePassword Lib "mpr" Alias "PwdChangePasswordA" _
        (ByVal lpcRegkeyname As String, ByVal hwnd As Long, ByVal _
        uiReserved1 As Long, ByVal uiReserved2 As Long) As Long
Declare Function VerifyScreenSavePwd Lib "password.cpl" (ByVal hwnd As _
        Long) As Long
Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _
        (lpVersionInformation As OSVERSIONINFO) As Long
Declare Function SystemParametersInfo Lib "user32" Alias _
        "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam _
        As Long, lpvParam As Long, ByVal fuWinIni As Long) As Long
Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal _
        nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As _
        Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal _
        nIDEvent As Long) As Long
Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As _
        Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) _
        As Long

Public Const KEYEVENTF_KEYUP = &H2
Public Const VK_ESCAPE = &H1B
Public Const WM_TIMER = &H113
Public Const SPI_SCREENSAVERRUNNING = 97
Public Const VER_PLATFORM_WIN32_NT = 2
Public Const WS_CHILD = &H40000000
Public Const GWL_WNDPROC = (-4)
Public Const WM_MOUSEMOVE = &H200
Public Const WM_CLOSE = &H10
Public Const HWND_TOPMOST = -1
Public Const SWP_SHOWWINDOW = &H40
Public Const GWL_STYLE = (-16)
Public Const ERROR_ALREADY_EXISTS = 183&
Public Const WM_ACTIVATE = &H6
Public Const WM_ACTIVATEAPP = &H1C
Public Const WM_SYSCOMMAND = &H112
Public Const SC_SCREENSAVE = &HF140&
Public Const SM_XVIRTUALSCREEN = 76
Public Const SM_YVIRTUALSCREEN = 77
Public Const SM_CXVIRTUALSCREEN = 78
Public Const SM_CYVIRTUALSCREEN = 79

Private m_ScreenSaver As clsScreenSaver 'Screen saver class, mostly
 ' used to catch the form's events

Private m_hWnd As Long 'hWnd of main form
Private m_lpPrevProc As Long 'Previous window procedure
Private m_hMutex As Long 'Handle to mutex to prevent multiple instances

Sub Main()
    
    DoEvents 'Gets rid of stray windows events
    
    Dim rt As RECT
    Dim hwnd As Long
    
    Select Case LCase(Mid(Command$, 1, 2))
        Case "/a" 'Password
            
            'Trigger the change password dialog
            PwdChangePassword "SCRSAVE", Val(Mid(Command$, 3)), 0&, 0&
            
        Case "", "/s" 'Show screen saver
            
            'Create a mutex to prevent two instances of the screen
            ' saver starting.  This is used vs App.PrevInstance
            ' because I want to allow a preview window and the
            ' screen saver to co-exist
            m_hMutex = CreateMutex(ByVal 0, True, MUTEX_NAME & _
                                   "[Saver]")
                                   
            'Did the mutex already exist?
            If Err.LastDllError = ERROR_ALREADY_EXISTS Then
                ReleaseMutex m_hMutex
                CloseHandle m_hMutex
                Exit Sub
            End If
            If m_hMutex = 0 Then
                Exit Sub
            End If
            
            'Create the screensaver class and point it to our form
            Set m_ScreenSaver = New clsScreenSaver
            Set m_ScreenSaver.Form = frmScreenSaver
            
            Load frmScreenSaver
            
            'Display the form full-screen and topmost
            Dim nWidth As Long
            Dim nHeight As Long
            Dim nLeft As Long
            Dim nTop As Long
            
            ' Attempt to find Multi-mon information
            nWidth = GetSystemMetrics(SM_CXVIRTUALSCREEN)
            nHeight = GetSystemMetrics(SM_CYVIRTUALSCREEN)
            nLeft = GetSystemMetrics(SM_XVIRTUALSCREEN)
            nTop = GetSystemMetrics(SM_YVIRTUALSCREEN)
            
            If nWidth <> 0 And nHeight <> 0 Then
                SetWindowPos frmScreenSaver.hwnd, HWND_TOPMOST, nLeft, _
                             nTop, nWidth, nHeight, SWP_SHOWWINDOW
            Else
                'It looks like we couldn't find multi-mon info,
                ' just fall back to VB's intrinsic handlers
                SetWindowPos frmScreenSaver.hwnd, HWND_TOPMOST, 0, 0, _
                             Screen.Width / Screen.TwipsPerPixelX, _
                             Screen.Height / Screen.TwipsPerPixelY, _
                             SWP_SHOWWINDOW
            End If
        Case "/p" 'Tiny preview window the display properties
            
            'Create the screensaver class and let it know
            ' that it's in a preview window
            Set m_ScreenSaver = New clsScreenSaver
            Set m_ScreenSaver.Form = frmScreenSaver
            m_ScreenSaver.IsPreview = True
            
            'Make the main form a child of the display properties
            SetWindowLong frmScreenSaver.hwnd, GWL_STYLE, _
                          GetWindowLong(frmScreenSaver.hwnd, GWL_STYLE) _
                          Or WS_CHILD
            SetParent frmScreenSaver.hwnd, Val(Mid(Command$, 3))
            
            'Get the size of the little display window
            GetWindowRect Val(Mid(Command$, 3)), rt
            
            Load frmScreenSaver
            'Show the window, not topmost, and the size specified
            SetWindowPos frmScreenSaver.hwnd, 0, 0, 0, rt.Right - _
                         rt.Left, rt.Bottom - rt.Top, SWP_SHOWWINDOW
            
        Case "/c" 'Settings
            
            'Use a mutex to prevent multiple display settings
            ' dialogs
            m_hMutex = CreateMutex(ByVal 0, True, MUTEX_NAME & _
                       "[Setting]")
            If Err.LastDllError = ERROR_ALREADY_EXISTS Then
                ReleaseMutex m_hMutex
                CloseHandle m_hMutex
                Exit Sub
            End If
            If m_hMutex = 0 Then
                Exit Sub
            End If
            
            ' I was lazy, you'll want to replace this with your
            '  own form
            MsgBox "No settings", vbInformation, "Sorry"
            
            ReleaseMutex m_hMutex
            CloseHandle m_hMutex
    End Select
    
End Sub

Public Sub Hook(hwnd As Long)
    'Procedure to subclass the main form
    
    m_hWnd = hwnd
    m_lpPrevProc = SetWindowLong(m_hWnd, GWL_WNDPROC, AddressOf WndProc)
    
End Sub

Public Sub Unhook()
    'Cease subclassing of the main form
    
    SetWindowLong m_hWnd, GWL_WNDPROC, m_lpPrevProc
    
    ReleaseMutex m_hMutex
    CloseHandle m_hMutex
    
End Sub

Public Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal _
       wParam As Long, ByVal lParam As Long) As Long
    ' This is the subclassed window procedure, basically, look for
    '  loss of focus, and the timer to dismiss the password dialog

    Dim bBlockMsg As Boolean 'Block this message from being sent

    Select Case uMsg
        Case WM_SYSCOMMAND
            If wParam = SC_SCREENSAVE Then
                'Stop WinNT from trying to re-enable the screen saver
                ' and disabling it if the password is on
                bBlockMsg = True
            End If
        Case WM_ACTIVATE, WM_ACTIVATEAPP
            If wParam = 0 Then
                PostMessage m_hWnd, WM_MOUSEMOVE, 0, 0
            End If
        Case WM_TIMER
            If m_ScreenSaver.IsPasswordVisible Then
                If GetTickCount - m_ScreenSaver.PasswordShown > 30000 _
                      Then
                    keybd_event VK_ESCAPE, 0, 0, 0
                    keybd_event VK_ESCAPE, 0, KEYEVENTF_KEYUP, 0
                End If
            End If
    End Select
    
    'Pass the message to VB's window procedure if it's not blocked
    If Not bBlockMsg Then
        WndProc = CallWindowProc(m_lpPrevProc, hwnd, uMsg, _
                  wParam, lParam)
    End If
    
End Function

' End: Module modScreenSaver
' ---------------------------------------------------------------------

' ---------------------------------------------------------------------
' Begin: Class Module clsScreenSaver

Option Explicit

Private WithEvents m_Form As Form 'The form that this class
' is watching

Private m_bPreview As Boolean 'Are we in the display properies?

Private m_ptLast As POINTAPI 'The last seen mouse position
Private m_bLast As Boolean 'Is the last seen mouse position valid
Private m_nTickLoad As Long 'Time that the form loaded
Private m_bPasswordVisible As Boolean 'Pwd dialog displayed?
Private m_nPasswordShown As Long 'Time pwd dialog shown

Public Property Get PasswordShown() As Long
    PasswordShown = m_nPasswordShown
End Property

Public Property Get IsPasswordVisible() As Boolean
    IsPasswordVisible = m_bPasswordVisible
End Property

Public Property Set Form(newForm As Form)
    Set m_Form = newForm
End Property

Public Property Let IsPreview(bPreview As Boolean)
    m_bPreview = bPreview
End Property

Public Property Get IsPreview() As Boolean
    IsPreview = m_bPreview
End Property

Private Sub Class_Initialize()
    
    'Just make note of the display time, that way we can ignore
    ' mouse and keyboard events for 1/2 a second, so the stray
    ' events don't trigger the unload
    
    m_nTickLoad = GetTickCount
    
End Sub

Private Sub m_Form_KeyUp(KeyCode As Integer, Shift As Integer)
    
    'Key press, call the generic unload procedure
    TriggerUnload
    
End Sub

Private Sub m_Form_Load()
    
    If Not m_bPreview Then
        Hook m_Form.hwnd ' Subclass this form to watch for
                        ' the timer and focus events
        
        ShowCursor False 'Hide the mouse cursor
        Dim nTemp As Long
        ' Let windows know we're running, primarily to
        '  prevent the system keys
        SystemParametersInfo SPI_SCREENSAVERRUNNING, 1, nTemp, 0
    End If
    
End Sub

Private Sub m_Form_MouseMove(Button As Integer, Shift As Integer, X As _
        Single, Y As Single)
    
    If Not m_bLast Then
        'If the last mouse cursor position hasn't been used yet,
        ' save the current position
        GetCursorPos m_ptLast
        m_bLast = True
        Exit Sub
    End If
    
    'Compare the last with the current, if they differ, trigger
    ' the generic unload procedure
    Dim pt As POINTAPI
    GetCursorPos pt
    If pt.X <> m_ptLast.X Or pt.Y <> m_ptLast.Y Then
        TriggerUnload
        m_ptLast.X = pt.X
        m_ptLast.Y = pt.Y
    End If
    
End Sub

Private Sub m_Form_MouseUp(Button As Integer, Shift As Integer, X As _
        Single, Y As Single)
    
    'Mouse button pressed, trigger the generic unload procedure
    TriggerUnload
    
End Sub

Private Sub m_Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    
    'Make sure we don't re-enter ourselves
    Static bInSub As Boolean
    
    If bInSub Then
        Exit Sub
    End If
    bInSub = True
    
    'This just displays the password dialog if the screen saver
    ' isn't being run in the display properties dialog.
    If Not m_bPreview Then
        If Not VerifyPassword Then
            Cancel = True
        Else
            Exit Sub
        End If
    End If
    
    ' Make note of the time incase the password was wrong
    m_nTickLoad = GetTickCount
    bInSub = False
    
End Sub

Private Sub m_Form_Unload(Cancel As Integer)
    'Undo what we did in Form_Load
    
    If Not m_bPreview Then
        Unhook
        
        ShowCursor True
        Dim nTemp As Long
        SystemParametersInfo SPI_SCREENSAVERRUNNING, False, nTemp, 0
    End If
    
End Sub

Private Sub TriggerUnload()
    
    ' Check to see if we should unload because of user actions,
    '  if so, then check to see if it's been atleast 1/2 a
    '  second since we started.
    
    If m_bPreview Then
        Exit Sub
    End If
    
    If GetTickCount - m_nTickLoad > 500 Then
        'Just use postmessage to avoid the problems with
        ' forcing and unload this very instant
        PostMessage m_Form.hwnd, WM_CLOSE, 0, 0
    End If
    
End Sub

Public Function VerifyPassword() As Boolean
    'Display and verify the users password
    
    'Check to see if this is NT.  If it is, let the os handle
    ' the password
    Dim osv As OSVERSIONINFO
    osv.dwOSVersionInfoSize = Len(osv)
    GetVersionEx osv
    
    If osv.dwPlatformId = VER_PLATFORM_WIN32_NT Then
        VerifyPassword = True
        Exit Function
    End If
    
    ShowCursor True 'The cursor should be visible for this
    m_bPasswordVisible = True
    m_nPasswordShown = GetTickCount
    SetTimer m_Form.hwnd, TIMER_ID, 1000, 0 'Used to dismiss
      'the password dialog after 30 seconds
    
    'Call the DLL function and return it's result
    VerifyPassword = (VerifyScreenSavePwd(m_Form.hwnd) <> 0)
    
    'Kill the timer, and hide the cursor (if the password is
    ' right, the cursor will be redisplayed when the form is
    ' killed
    KillTimer m_Form.hwnd, TIMER_ID
    m_bPasswordVisible = False
    ShowCursor False
    
End Function

' End: Class Module clsScreenSaver
' ---------------------------------------------------------------------

n/a