How to lock a computer half-decently

[kazar]

This guide tells you how to create a half-decent vb7 computer locking programme which:

• Disables the Task Manager
• Disables ALT-TAB
• Disables Window Key
• Disables the Cursor

First things first, you have to make a form, with a textbox on it for the password, and remove the borders. Set the Form to Maximise at start, add a timer, and then we can start the code. You can set the timer to any intervale you want, but it works much better in the range 1-10
This code is used to make the locker.

Option Explicit
Sub Form_Load
 
App.TaskVisible = False
'this line prevents the app from showing in the app pane of Task Manager
 
Call SetWindowPos(Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
'This part is fairly standard - it ensures that the form always stays on top.
 
Module1.Hook
'This starts a hook which is explained down a bit.
 
ShowCursor (False)
'this hides the cursor
 
Module1.SendKey (VK_TAB)
'this line is optional. but it selects your textbox when it loads.
End Sub
 
Private Sub Timer1_Timer()
 
    SetForegroundWindow (Me.hwnd)
'this part makes sure that your screen is the foreground window every tick
 
Call SetWindowPos(Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
'this repeats the topmost call, and is the code that hides task manager as soon as it loads, and activates your form.
 
 
 
  Call keybd_event(VK_LWIN, MapVirtualKey(VK_LWIN, 0),KEYEVENTF_EXTENDEDKEY + KEYEVENTF_KEYUP, 0)
'this line sets the windows key to up, even if it isn't down.
 
Call keybd_event(VK_MENU, MapVirtualKey(VK_MENU, 0), _
     KEYEVENTF_EXTENDEDKEY + KEYEVENTF_KEYUP, 0)
     Call keybd_event(VK_ESCAPE, MapVirtualKey(VK_ESCAPE, 0), _
     KEYEVENTF_EXTENDEDKEY + KEYEVENTF_KEYUP, 0)
'these two lines assist in the code but are not definetly needed, they just capture and prevent the esc and alt keys inside your app.
 
Call SetWindowPos(Form1.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
' i call the topmost command again, just to ensure that the task manager didn't show while the code was running
End Sub
 
Private Sub passbox_Change()
If passbox.Text = pass Then
    ShowCursor (True)
'reshows the cursor
    Module1.Unhook
'removes the hook
    Unload Me
'closes the form
End If
 
End Sub
 
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If Not Text1.Text = pass Then
    Cancel = -1
' this line of code prevents the app from closing on most occasions.  But not all, so i use a hook later.
End If

Then this is a module to run the hook as well as types and declarations.

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" ( _
                ByVal hwnd As Long, _
                ByVal nIndex As Long) As Long
 
Private Declare Function SetLayeredWindowAttributes Lib "user32" ( _
                ByVal hwnd As Long, _
                ByVal crKey As Long, _
                ByVal bAlpha As Byte, _
                ByVal dwFlags As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As rect) As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Private 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
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Const SW_HIDE = 0
Const SW_NORMAL = 1
Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const GWL_STYLE = (-16)
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_COLORKEY = &H1
Private Const LWA_ALPHA = &H2
Const MAX_TOOLTIP As Integer = 64
Const NIF_ICON = &H2
Const NIF_MESSAGE = &H1
Const NIF_TIP = &H4
Const NIM_ADD = &H0
 Const NIM_DELETE = &H2
 Const WM_MOUSEMOVE = &H200
Const WM_LBUTTONDOWN = &H201
Const WM_LBUTTONUP = &H202
Const WM_LBUTTONDBLCLK = &H203
Const WM_RBUTTONDOWN = &H204
Const WM_RBUTTONUP = &H205
Const WM_RBUTTONDBLCLK = &H206
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Dim endmsg As MSG
Public pass As String
Private Const VK_LWIN = &H5B  '91    'Left Windows key = &HMicrosoft® Natural® keyboard  '
Private Const VK_ESCAPE = &H1B  '27  'ESC key
Private Const VK_SHIFT = &H10  '16   'SHIFT key
Private Const VK_CONTROL = &H11  '17 'CTRL key
Private Const VK_MENU = &H12  '18    'ALT key
Private Const VK_RBUTTON = &H2  '2   'Right mouse button
Private Const VK_APPS = &H5D  '93    'Applications key = &HNatura
Const VK_TAB = &H9
Private Declare Sub keybd_event Lib "user32" _
  (ByVal bVk As Byte, ByVal bScan As Byte, _
  ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
 
Private Declare Function MapVirtualKey Lib "user32" _
   Alias "MapVirtualKeyA" _
  (ByVal wCode As Long, ByVal wMapType As Long) As Long
 
Private Const KEYEVENTF_EXTENDEDKEY = &H1
Private Const KEYEVENTF_KEYUP = &H2
 
Public Const WM_NULL = &H0
Public Const WM_CREATE = &H1
Public Const WM_DESTROY = &H2
Public Const WM_MOVE = &H3
Public Const WM_SIZE = &H5
Type rect
    left As Long
    right As Long
    Top As Long
    Bottom As Long
End Type
 
Type POINTAPI
    X As Long
    Y As Long
End Type
Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Declare Function GetFocus Lib "user32" () 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 SetFocus Lib "user32" (ByVal hwnd 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 UnregisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long) As Long
Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long
Declare Function RegisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Type MSG
    hwnd    As Long
    message As Long
    wParam  As Long
    lParam  As Long
    time    As Long
    pt      As POINTAPI
End Type
Declare Function SendInput Lib "user32.dll" (ByVal nInputs As Long, pInputs As GENERALINPUT, ByVal cbSize As Long) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Public Const GWL_WNDPROC = -4
Public Const WM_QUERYENDSESSION = &H11
Public Const WM_CANCELMODE = &H1F
 
Public SDAttempt        As Long
Global lpPrevWndProc    As Long
Global gHW              As Long
Const VK_H = 72
Const VK_E = 69
Const VK_L = 76
Const VK_O = 79
Const KEYEVENTF_KEYUP = &H2
Const INPUT_MOUSE = 0
Const INPUT_KEYBOARD = 1
Const INPUT_HARDWARE = 2
 
Type MOUSEINPUT
  dx As Long
  dy As Long
  mouseData As Long
  dwFlags As Long
  time As Long
  dwExtraInfo As Long
End Type
 Type KEYBDINPUT
  wVk As Integer
  wScan As Integer
  dwFlags As Long
  time As Long
  dwExtraInfo As Long
End Type
Type HARDWAREINPUT
  uMsg As Long
  wParamL As Integer
  wParamH As Integer
End Type
 Type GENERALINPUT
  dwType As Long
  xi(0 To 23) As Byte
End Type
 
Dim sSql    As String
 
 
'Holds on
Public Sub Hook()
'starts the hook
    lpPrevWndProc = SetWindowLong(gHW, GWL_WNDPROC, AddressOf WindowProc)
End Sub
 
'Lets close
Public Sub Unhook()
'ends the hook
    Dim temp    As Long
    temp = SetWindowLong(gHW, GWL_WNDPROC, lpPrevWndProc)
End Sub
 
Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long
    
    Dim a As Long
    
    If uMsg = WM_QUERYENDSESSION Then
        MsgBox "Logoff/Shutdown not permitted", vbSystemModal + vbCritical
        Hook
    End If
    
    WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
    
End Function
 
' this sub is used to send the tab key at the form_load
Public Sub SendKey(bKey As Byte)
    Dim GInput(0 To 1) As GENERALINPUT
    Dim KInput As KEYBDINPUT
    KInput.wVk = bKey  'the key we're going to press
    KInput.dwFlags = 0 'press the key
    'copy the structure into the input array's buffer.
    GInput(0).dwType = INPUT_KEYBOARD   ' keyboard input
    CopyMemory GInput(0).xi(0), KInput, Len(KInput)
    'do the same as above, but for releasing the key
    KInput.wVk = bKey  ' the key we're going to realease
    KInput.dwFlags = KEYEVENTF_KEYUP  ' release the key
    GInput(1).dwType = INPUT_KEYBOARD  ' keyboard input
    CopyMemory GInput(1).xi(0), KInput, Len(KInput)
    'send the input now
    Call SendInput(2, GInput(0), Len(GInput(0)))
End Sub

Thats it. I apologise of there is some unneccessary code, but i tend to dump a tonne of apis into a program, and then call them.

Use this wisely. Messing up the code too much can stop you computer from functioning properly.

[|2eM!x]

Not so sure this is a good thread..

[kazar]

Meaning What? This code is not designed to be hostile. It is designed for people who might want to lock a computer if a registration key is not entered etc. Good programmers don't write viruses. If i was to include my code to lock it even when you restarted, then yes, i understand that it would be somewhat iffy, but i have not.