Katsukidaito
asked on
Detect KeyBoard
I want to make project that can be detect keyboard when keyboard are pressed. OK I give you example when the program Run and when you pressed 's' and 'c' then the program will capture picture. Even when you on the other application like Note pad.SO I need to know How to make(source code will be nice) when the program run it will be stay on memory and when keyboard pressed the program will detect(for example) if the keyboard sequence 's' 'c'
then will capture picture in the Screen.
I just need source code how make program stay in windows memory and can detect when keyboard pressed with certain sequence. Than you Very much for your Help
then will capture picture in the Screen.
I just need source code how make program stay in windows memory and can detect when keyboard pressed with certain sequence. Than you Very much for your Help
module code:-
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
If nCode < 0 Then
HookProc = CallNextHookEx(hHook, nCode, wParam, lParam)
Exit Function
End If
Dim i%, j%
CopyMemory EMSG, ByVal lParam, Len(EMSG)
Select Case EMSG.wMsg
Case WM_KEYDOWN
If (hFlags And HFKeyDown) = HFKeyDown Then
If GetAsyncKeyState(vbKeyShif t) Then j = 1
If GetAsyncKeyState(vbKeyCont rol) Then j = 2
If GetAsyncKeyState(vbKeyMenu ) Then j = 4
If (EMSG.lParamLow And &HFF) > 31 Then
frmHooked.System_KeyDown MapVirtualKeyEx(EMSG.lPara mLow And &HFF, 2, GetKeyboardLayout(GetWindo wThreadPro cessId(Get Foreground Window, 0))), j
Else
frmHooked.System_KeyDown EMSG.lParamLow And &HFF, j
End If
End If
Case WM_KEYUP
If (hFlags And HFKeyUp) = HFKeyUp Then
If GetAsyncKeyState(vbKeyShif t) Then j = 1
If GetAsyncKeyState(vbKeyCont rol) Then j = 2
If GetAsyncKeyState(vbKeyMenu ) Then j = 4
If (EMSG.lParamLow And &HFF) > 31 Then
frmHooked.System_KeyUp MapVirtualKeyEx(EMSG.lPara mLow And &HFF, 2, GetKeyboardLayout(GetWindo wThreadPro cessId(Get Foreground Window, 0))), j
Else
frmHooked.System_KeyUp EMSG.lParamLow And &HFF, j
End If
End If
Case WM_MOUSEWHEEL
Debug.Print "MouseWheel"
Case WM_MOUSEMOVE
If (hFlags And HFMouseMove) = HFMouseMove Then
If GetAsyncKeyState(vbKeyLBut ton) Then i = 1
If GetAsyncKeyState(vbKeyRBut ton) Then i = 2
If GetAsyncKeyState(vbKeyMBut ton) Then i = 4
If GetAsyncKeyState(vbKeyShif t) Then j = 1
If GetAsyncKeyState(vbKeyCont rol) 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(vbKeyShif t) Then i = 1
If GetAsyncKeyState(vbKeyCont rol) 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(vbKeyShif t) Then i = 1
If GetAsyncKeyState(vbKeyCont rol) 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)
hHook = SetWindowsHookEx(WH_JOURNA LRECORD, 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
'Form code (you need 2 textboxes and a label text1,text2,label1)
Option Excplicit
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
If KeyCode > 31 Then
s = LCase(Chr$(KeyCode))
Else
s = "ASCII code " & KeyCode
End If
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
If KeyCode > 31 Then
s = LCase(Chr$(KeyCode))
Else
s = "ASCII code " & KeyCode
End If
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
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
If nCode < 0 Then
HookProc = CallNextHookEx(hHook, nCode, wParam, lParam)
Exit Function
End If
Dim i%, j%
CopyMemory EMSG, ByVal lParam, Len(EMSG)
Select Case EMSG.wMsg
Case WM_KEYDOWN
If (hFlags And HFKeyDown) = HFKeyDown Then
If GetAsyncKeyState(vbKeyShif
If GetAsyncKeyState(vbKeyCont
If GetAsyncKeyState(vbKeyMenu
If (EMSG.lParamLow And &HFF) > 31 Then
frmHooked.System_KeyDown MapVirtualKeyEx(EMSG.lPara
Else
frmHooked.System_KeyDown EMSG.lParamLow And &HFF, j
End If
End If
Case WM_KEYUP
If (hFlags And HFKeyUp) = HFKeyUp Then
If GetAsyncKeyState(vbKeyShif
If GetAsyncKeyState(vbKeyCont
If GetAsyncKeyState(vbKeyMenu
If (EMSG.lParamLow And &HFF) > 31 Then
frmHooked.System_KeyUp MapVirtualKeyEx(EMSG.lPara
Else
frmHooked.System_KeyUp EMSG.lParamLow And &HFF, j
End If
End If
Case WM_MOUSEWHEEL
Debug.Print "MouseWheel"
Case WM_MOUSEMOVE
If (hFlags And HFMouseMove) = HFMouseMove Then
If GetAsyncKeyState(vbKeyLBut
If GetAsyncKeyState(vbKeyRBut
If GetAsyncKeyState(vbKeyMBut
If GetAsyncKeyState(vbKeyShif
If GetAsyncKeyState(vbKeyCont
If GetAsyncKeyState(vbKeyMenu
frmHooked.System_MouseMove
End If
Case WM_LBUTTONDOWN, WM_RBUTTONDOWN, WM_MBUTTONDOWN
If (hFlags And HFMouseDown) = HFMouseDown Then
If GetAsyncKeyState(vbKeyShif
If GetAsyncKeyState(vbKeyCont
If GetAsyncKeyState(vbKeyMenu
frmHooked.System_MouseDown
End If
Case WM_LBUTTONUP, WM_RBUTTONUP, WM_MBUTTONUP
If (hFlags And HFMouseUp) = HFMouseUp Then
If GetAsyncKeyState(vbKeyShif
If GetAsyncKeyState(vbKeyCont
If GetAsyncKeyState(vbKeyMenu
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)
hHook = SetWindowsHookEx(WH_JOURNA
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
Window_SetAlwaysOnTop = SetWindowPos(hwnd, -2 - bAlwaysOnTop, 0, 0, 0, 0, SWP_NOREDRAW Or SWP_NOSIZE Or SWP_NOMOVE)
End Function
'Form code (you need 2 textboxes and a label text1,text2,label1)
Option Excplicit
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
If KeyCode > 31 Then
s = LCase(Chr$(KeyCode))
Else
s = "ASCII code " & KeyCode
End If
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
If KeyCode > 31 Then
s = LCase(Chr$(KeyCode))
Else
s = "ASCII code " & KeyCode
End If
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
Will that work as katsukidaito wants? If the app doesn't have focus, do you get the messages? You really need a system wide hook and I thought you couldn't set system hooks into VB code.
There's a nice article on system wide hooks with a library you can use at:
http://vbaccelerator.com/codelib/hook/vbalhook.htm
There's a nice article on system wide hooks with a library you can use at:
http://vbaccelerator.com/codelib/hook/vbalhook.htm
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Thank You Very MUch For Your Kindness.
Visual Basic So MUch toLearn CAn you Help me Again?
Visual Basic So MUch toLearn CAn you Help me Again?
I'll makie it clear..
Ex:
In notepad or any other application like MS-WORD etc..
i want to display only 'A'...for any input from the keyboard..for this i can use Windows Hook api..u can code
to change for all the ACII values to ASCII value for 'A'