Ejemplos usando el Api de windows para Visual basic

234 - Hook para bloquear el mouse y el teclado

Dos ejemplos en visual basic que implementan un Hook para poder bloquear el teclado y mouse a nivel de sistema

Bloquear el teclado y mouse completamente por un tiempo
Bloquear la estación de trabajo

1 - Bloquear el teclado y mouse

Este ejemplo lo extraí de este programa : Bloquear PC creado por Tim Bates.

y lo que hace el código es bloquear a nivel de sistema, el teclado y mouse mediante un Hook, por un tiempo determinado. Ese tiempo se establece en la variable Tiempobloqueo en donde se le especifican los segundos en que el Hook estará activo.

Ejemplo

Agregar un módulo bas
Un control Timer
Un CommandButton

Código fuente en el form

Option Explicit ' flag para saber si está o no bloqueado Dim Bloqueado As Boolean ' variable para establecer los segundos de bloqueo Dim TiempoBloqueo As Integer ' Sub que instala los Hook para bloquear el teclado y mouse ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Bloquear() Me.WindowState = vbMaximized Timer1.Enabled = True ' Pone la ventana Always OnT op SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS ' deshabilita el teclado IdKeyBoard = SetWindowsHookEx(WH_KEYBOARD_LL, _ AddressOf WinProcKeyBoard, _ App.hInstance, 0) ' deshabilita el mouse IdMouse = SetWindowsHookEx(WH_MOUSE_LL, _ AddressOf WinProcMouse, _ App.hInstance, 0) ' setea el flag Bloqueado = True End Sub 'sub que elimina los Hook para el teclado y mouse ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub Desbloquear() ' Vuelve a Habilitar el teclado If IdKeyBoard <> 0 Then UnhookWindowsHookEx IdKeyBoard ' Vuelve a Habilitar el mouse If IdMouse <> 0 Then UnhookWindowsHookEx IdMouse ' cambia el flag Bloqueado = False ' cierra el timer y restaura la ventana Timer1.Enabled = False Me.WindowState = vbNormal Me.Cls End Sub ' Botón que bloquea el teclado y el mouse ''''''''''''''''''''''''''''''''''''''''''' Private Sub Command1_Click() Bloqueado = True Bloquear End Sub Private Sub Form_Click() End End Sub Private Sub Form_Load() Bloqueado = False ' tiempo de bloqueo 10 segundos TiempoBloqueo = 10 Me.BackColor = vbRed Me.FontSize = 20 Me.ForeColor = vbWhite Me.AutoRedraw = True Timer1.Interval = 1000 Timer1.Enabled = False Command1.Caption = "Bloquear" End Sub Private Sub Timer1_Timer() Static segundos As Integer ' Increase count of seconds that have passed segundos = segundos + 1 'Check if time is up If segundos >= TiempoBloqueo Then 'If it is, unlock Desbloquear 'And then reset the timer's second count segundos = 0 End If Cls Me.Print "Mouse y KeyBoard bloquedo. Tiempo : " & _ segundos & " de : "; TiempoBloqueo & " ..segundos" End Sub

Código fuente en el módulo bas

Option Explicit 'Declare needed functions from Windows API Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _ Destination As Any, _ Source As Any, _ ByVal Length As Long) Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer Public Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" ( _ ByVal idHook As Long, _ ByVal lpfn As Long, _ ByVal hmod As Long, _ ByVal dwThreadId As Long) As Long Public Declare Function CallNextHookEx Lib "user32" ( _ ByVal hHook As Long, _ ByVal nCode As Long, _ ByVal wParam As Long, _ lParam As Any) As Long Public Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long Public 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 'Always on Top constants Public Const HWND_TOPMOST = -1 Public Const HWND_NOTOPMOST = -2 Public Const SWP_NOMOVE = &H2 Public Const SWP_NOSIZE = &H1 Public Const TOPMOST_FLAGS = SWP_NOMOVE Or SWP_NOSIZE 'Keyboard related Constants and Structs Public Const WH_KEYBOARD_LL = 13 Public Const LLKHF_ALTDOWN = &H20 Public Type KBDLLHOOKSTRUCT vkCode As Long scanCode As Long flags As Long time As Long dwExtraInfo As Long End Type 'Keyboard related variables 'Dim p As KBDLLHOOKSTRUCT Public IdKeyBoard As Long 'Mouse related Constants and Structs Public Const WH_MOUSE_LL = 14 'Mouse related variables 'Dim p2 As MSLLHOOKSTRUCT Public IdMouse As Long 'función que desactiva el teclado ''''''''''''''''''''''''''''''''' Public Function WinProcKeyBoard(ByVal nCode As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long WinProcKeyBoard = -1 End Function 'función que desactiva el Mouse ''''''''''''''''''''''''''''''' Public Function WinProcMouse(ByVal nCode As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long WinProcMouse = -1 End Function

2 - Bloquear la estación de trabajo

Código fuente probado solo en windows xp

Este otro ejemplo, es similar al anterior, y deshabilita el mouse por completo y el teclado en forma parcial.

Lo que hace es maximizar la ventana del formulario y la pone AlwaysOnTop. A su ves bloquea el teclado completo, menos las teclas para los números y las teclas desde la a-z. ( Para que en un textox se pueda escribir un password y volver a habilitar todo, es decir remover el Hook )

También se habilita la tecla delete, Tab y la de retroceso

Tambien , el ejemplo comprueba ( dentro del procedimiento que hace el Hook (IsHooked )) , constantemente si se intenta abrir el administrador de tareas, ya que por mas que el teclado esté totalmente desactivado, las teclas ctrl+alt+sup no las desactiva. Entonces si se abre el Administrador de tareas , se cierra con el Api SendMessage.

Ejemplo

Colocar en el formulario un Text1 y agregar al proyecto un módulo bas

Importante : Una ves bloqueado todo, escribir en el textbox > 123 y presionar Enter , para poder reestablecer el formulario a su estado normal y también desbloquear el KeyBoard y el mouse

Nota: al probar el código , hacer backup y copias del proyecto y corregir los errores , por que cualquier error mientras corra el hook, se cerrará el programa inesperadamente, inclusive el Ide de visual basic . y es muy posible que haya que reiniciar la pc, ya que el teclado y el mouse quedarán bloqueados

Código fuente en el formulario

Option Explicit Private Sub Form_Activate() Text1.SetFocus End Sub Private Sub Form_Load() MsgBox "IMPORTANTE !!! Para desbloquear escribir: 123, " & _ "y presionar Enter", vbInformation ' Inicia El hook para el teclado y para el mouse Call IniciarHook(Me.hwnd) ' maximizado Me.WindowState = 2 Text1 = "" End Sub Private Sub Form_Unload(Cancel As Integer) ' finaliza el Hook Call FinalizarHook(Me.hwnd) End Sub ' textbox para desbloquear '''''''''''''''''''''''''''''''''''' Private Sub Text1_KeyPress(KeyAscii As Integer) If Text1 = "123" And KeyAscii = vbKeyReturn Then Call FinalizarHook(Me.hwnd) ' finaliza el Hook End If End Sub

Código fuente en el módulo bas

Option Explicit '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Declaraciones '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' funciones para instalar y quitar el Hook al teclado '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Declare Function UnhookWindowsHookEx Lib "user32" _ (ByVal hHook As Long) As Long Public Declare Function SetWindowsHookEx Lib "user32" _ Alias "SetWindowsHookExA" (ByVal idHook As Long, _ ByVal lpfn As Long, _ ByVal hmod As Long, _ ByVal dwThreadId As Long) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _ pDest As Any, _ pSource As Any, _ ByVal cb As Long) Private Declare Function CallNextHookEx Lib "user32" _ (ByVal hHook As Long, _ ByVal nCode As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long ' Función para retornar el Hwnd del Admin a partir del caption '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _ ByVal lpClassName As String, _ ByVal lpWindowName As String) As Long 'Declaración del Api SendMessage ( cierra el Administrador de tareas ) Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _ ByVal hwnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ lParam As Any) As Long Public 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 'Declaraciones API para eliminar el titlebar en tiempo de ejecución Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long 'Constante para usar con GetWindowLong y SetWindowLong Private Const GWL_STYLE = (-16) 'Constante Tipo de estilo, en este caso para quitar la barra Private Const WS_CAPTION = &HC00000 'Constantes para SetWindowPos Private Const SWP_FRAMECHANGED = &H20 Private Const SWP_NOZORDER = &H4 'Always on Top constants Public Const HWND_TOPMOST = -1 Public Const HWND_NOTOPMOST = -2 Public Const SWP_NOMOVE = &H2 Public Const SWP_NOSIZE = &H1 Public Const TOPMOST_FLAGS = SWP_NOMOVE Or SWP_NOSIZE 'Constante para sendMessage Private Const SC_CLOSE = &HF060& Private Const WM_SYSCOMMAND = &H112 Private Type KBDLLHOOKSTRUCT vkCode As Long scanCode As Long flags As Long time As Long dwExtraInfo As Long End Type Private Const HC_ACTION = 0 Private Const WH_MOUSE_LL As Long = 14 Private Const WH_KEYBOARD_LL = 13& Public KeyboardHandle As Long Public IdMouse As Long Private Const CAPTION_TASKBAR As String = "Administrador de tareas de windows" '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'Fin declaraciones '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' funciones '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' si IsHooked retorna False, deshabilita Todo '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function IsHooked(ByRef Hookstruct As KBDLLHOOKSTRUCT) As Boolean ' Hwnd de la la barra de tareas Dim Hwnd_TaskBar As Long ' busca el Hwnd del Task Manager Hwnd_TaskBar = FindWindow(vbNullString, CAPTION_TASKBAR) ' comprueba si el Admin de tareas está abierto If Hwnd_TaskBar <> 0 Then ' Lo cierra Call SendMessage(Hwnd_TaskBar, WM_SYSCOMMAND, SC_CLOSE, ByVal 0&) End If ' comprueba la tecla de retroceso If Hookstruct.vkCode = vbKeyBack Then IsHooked = False ' indica que se habilita esta tecla Exit Function End If ' comprueba la tecla Tab If Hookstruct.vkCode = vbKeyTab Then IsHooked = False Exit Function End If ' comprueba la tecla delete If Hookstruct.vkCode = vbKeyDelete Then IsHooked = False Exit Function End If ' comprueba la tecla Enter If Hookstruct.vkCode = vbKeyReturn Then IsHooked = False Exit Function End If '... otras ' Comprueba las teclas para los números y desde la a-z If (Hookstruct.vkCode < 48) Or Hookstruct.vkCode > 90 Then IsHooked = True End If Exit Function End Function Public Function KeyboardCallback(ByVal Code As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long Static Hookstruct As KBDLLHOOKSTRUCT If (Code = HC_ACTION) Then Call CopyMemory(Hookstruct, ByVal lParam, Len(Hookstruct)) If (IsHooked(Hookstruct)) Then KeyboardCallback = 1 Exit Function End If End If ' deshabilita el mouse y las teclas KeyboardCallback = CallNextHookEx(KeyboardHandle, Code, wParam, lParam) End Function 'función que desactiva el Mouse ''''''''''''''''''''''''''''''' Public Function WinProcMouse(ByVal nCode As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long WinProcMouse = -1 End Function ' recibe el Hwnd del formulario '''''''''''''''''''''''''''''''''''''''''''' Public Sub IniciarHook(HwndForm As Long) ' hook para el teclado, pasándole el nombre de la función "KeyboardCallback" KeyboardHandle = SetWindowsHookEx(WH_KEYBOARD_LL, _ AddressOf KeyboardCallback, _ App.hInstance, 0&) ' hook para el mouse ( lo deshabilita ) le pasa función WinProcMouse IdMouse = SetWindowsHookEx(WH_MOUSE_LL, _ AddressOf WinProcMouse, _ App.hInstance, 0) 'Le saca la barra de título al formulario Call Quitar_Barra_Titulo(HwndForm, False) ' Pone la ventana Always OnT op Call SetWindowPos(HwndForm, HWND_TOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS) End Sub ' función que elimina el Titlebar en tiempo de ejecución '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Quitar_Barra_Titulo(ByVal hwnd As Long, _ ByVal Quitar As Boolean) Dim El_Estilo As Long El_Estilo = GetWindowLong(hwnd, GWL_STYLE) If Quitar Then El_Estilo = El_Estilo Or WS_CAPTION Else El_Estilo = El_Estilo And Not WS_CAPTION End If SetWindowLong hwnd, GWL_STYLE, El_Estilo SetWindowPos hwnd, 0, 0, 0, 0, 0, _ SWP_FRAMECHANGED Or _ SWP_NOMOVE Or _ SWP_NOSIZE Or _ SWP_NOZORDER End Sub ' Función que usa UnhookWindowsHookEx, para saber si el Hook se ha inicializado '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Function Hooked() Hooked = KeyboardHandle <> 0 End Function Public Sub FinalizarHook(HwndForm As Long) If (Hooked) Then ' termina el Hook Call UnhookWindowsHookEx(KeyboardHandle) Call UnhookWindowsHookEx(IdMouse) ' reestablece el estilo anterior de la ventana Quitar_Barra_Titulo HwndForm, True ' Quita la ventana Always OnT op SetWindowPos HwndForm, HWND_NOTOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS End If End Sub

Nota: Parte de este ejemplo lo saqué de la web de Microsoft. Dicho ejemplo, lo que mostraba era como desactivar las teclas de sistema Alt+Tab , Alt+esc y Ctrl+Esc

Buscar en Recursos vb