Link to home
Start Free TrialLog in
Avatar of Katsukidaito
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
Avatar of javudai
javudai

hi for that u can use Window hook - API... this api will give u what is the value(ASCII) is coming from the keyboard,U can display some another value for the coresponding input value...

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'
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(vbKeyShift) Then j = 1
          If GetAsyncKeyState(vbKeyControl) Then j = 2
          If GetAsyncKeyState(vbKeyMenu) Then j = 4
          If (EMSG.lParamLow And &HFF) > 31 Then
             frmHooked.System_KeyDown MapVirtualKeyEx(EMSG.lParamLow And &HFF, 2, GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, 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(vbKeyShift) Then j = 1
          If GetAsyncKeyState(vbKeyControl) Then j = 2
          If GetAsyncKeyState(vbKeyMenu) Then j = 4
          If (EMSG.lParamLow And &HFF) > 31 Then
             frmHooked.System_KeyUp MapVirtualKeyEx(EMSG.lParamLow And &HFF, 2, GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, 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(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)
   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



'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
ASKER CERTIFIED SOLUTION
Avatar of PeteD
PeteD

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of Katsukidaito

ASKER

Thank You Very MUch For Your Kindness.
Visual Basic So MUch toLearn CAn you Help me Again?