Security Lock-Out Screen

This example shows you how to create a 'lock-out' screen, so that users have to enter a password before being able to use the PC. (Note that this is basic, only works on Windows 9x, and should not be treated as truly secure!)

First, add a label called lblCountDown, a TextBox called txtPass (with its password property set to *), and a timer called tmrCountDown. Next, add the following code to a form

Option Explicit
Dim blnLocked As Boolean

Private Sub Form_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        '// return
        'Timer1.Enabled = False
        tmrCountDown.Enabled = True
        txtPass.Enabled = True
        '// set countdown to 5
        lblCountDown.Caption = "5 Seconds time to write a password."
        lblCountDown.Visible = True
        txtPass.Text = ""
        txtPass.Enabled = True
    End If
End Sub
Private Sub Form_Load()
    '// we are locked
    blnLocked = True
    '// disable ctrl+alt+del and Ctrl+Tab
    DisableCtrlAltDelete (True)
    '// make always on top
    MakeTopMost Form1.hwnd
    '// fill screen
    Left = 0
    Top = 0
    Width = Screen.Width
    Height = Screen.Height
    lblCountDown.Visible = False
End Sub
Private Sub Form_LostFocus()
    Form1.SetFocus
End Sub
Private Sub Form_Unload(Cancel As Integer)
    If blnLocked = True Then
        '// no exit
        Cancel = -1
    Else
        blnLocked = False
        DisableCtrlAltDelete (False)
    End If
End Sub

Private Sub txtPass_Change()
    '// check password
    If txtPass.Text = "mouse" Then
        blnLocked = False
        tmrCountDown.Enabled = False
        MsgBox "Password accepted"
        Unload Me
    End If
End Sub

Private Sub tmrCountDown_Timer()
    If Val(lblCountDown) = 0 Then
        '// timeout
        txtPass.Text = ""
        txtPass.Enabled = False
        tmrCountDown.Enabled = False
        lblCountDown.Visible = False
    Else
        '// countdown
        lblCountDown.Caption = Val(lblCountDown.Caption) - 1 & "  Seconds time to write a password."
        txtPass.SetFocus
    End If
End Sub




Finally, add this code to a module...


' Used for DisableCtrlAltDelete
Private Declare Function SystemParametersInfo Lib _
"user32" Alias "SystemParametersInfoA" (ByVal uAction _
As Long, ByVal uParam As Long, ByVal lpvParam As Any, _
ByVal fuWinIni As Long) As Long
'-------------------------------------------

' Used for ExitWindows
Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4
Private Declare Function ExitWindowsEx Lib "user32" _
(ByVal uFlags As Long, ByVal dwReserved _
As Long) As Long
' ---------------------
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2
Const SWP_NOMOVE = &H2
Const SWP_NOSIZE = &H1
Const SWP_NOACTIVATE = &H10
Const SWP_SHOWWINDOW = &H40
Const TOPMOST_FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, y, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Sub MakeNormal(Handle As Long)
    SetWindowPos Handle, HWND_NOTOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub
Public Sub MakeTopMost(Handle As Long)
    SetWindowPos Handle, HWND_TOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub

Sub ExitWindows(ExitMode As String)
 Select Case ExitMode
 Case Is = "shutdown"
     t& = ExitWindowsEx(EWX_SHUTDOWN, 0)
 Case Is = "reboot"
     t& = ExitWindowsEx(EWX_REBOOT Or EXW_FORCE, 0)
 Case Else
    MsgBox ("Error in ExitWindows call")
 End Select
 
 End Sub

Sub Center(FormName As Form)
 ' Center Forms...
 'Move (Screen.Width - FormName.Width) 2, (Screen.Height - FormName.Height) 2
End Sub
Sub DisableCtrlAltDelete(bDisabled As Boolean)
    ' Disables Control Alt Delete Breaking as well as Ctrl-Escape
    Dim x As Long
    x = SystemParametersInfo(97, bDisabled, CStr(1), 0)

End Sub

Sub OpenApp(File As String)
    'Shells to another application
    x = Shell(File)
End Sub