Форум программистов, компьютерный форум, киберфорум
The trick
Войти
Регистрация
Восстановить пароль
Рейтинг: 5.00. Голосов: 5.

Перехват событий мыши и клавиатуры в VB6

Запись от The trick размещена 23.01.2014 в 10:59
Обновил(-а) The trick 11.07.2015 в 00:18

Простой модуль для перехвата событий мыши и клавиатуры. События перехватываются в независимости от активности данного приложения (можно перехватывать в чужих окнах). Используются LowLevel хуки, также простой сменой LL -хука на обычный (без LL) можно перехватывать только в своем приложении. Также распознаеться программное нажатие через keybd_events, mouse_events от реального (насчет SendInput и SendKeys не проверял).
Модуль:
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
Option Explicit
 
' Модуль для перехвата событий ввода мыши и клавиатуры
' © Кривоус Анатолий Анатольевич (The trick), 2014
 
Private Type POINTAPI
    x As Long
    y As Long
End Type
Private Type MSLLHOOKSTRUCT
    pt As POINTAPI
    mouseData As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type
Private Type KBDLLHOOKSTRUCT
    VkCode As Long
    ScanCode As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type
 
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 Integer, lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
 
Private Const WH_KEYBOARD_LL = 13
Private Const WH_MOUSE_LL = &HE&
Private Const HC_ACTION = 0
Private Const LLKHF_INJECTED = &H10
Private Const LLMHF_INJECTED = 1
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const WM_SYSKEYDOWN As Long = &H104
Private Const WM_SYSKEYUP As Long = &H105
Private Const WM_MOUSEMOVE As Long = &H200
Private Const WM_LBUTTONDOWN As Long = &H201
Private Const WM_LBUTTONUP As Long = &H202
Private Const WM_MBUTTONDOWN As Long = &H207
Private Const WM_MBUTTONUP As Long = &H208
Private Const WM_RBUTTONDOWN As Long = &H204
Private Const WM_RBUTTONUP As Long = &H205
Private Const WM_MOUSEWHEEL As Long = &H20A
 
Dim hKeyHook As Long, hMouseHook As Long
 
Public Sub Hook()
    hKeyHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf LowLevelkbdProc, App.hInstance, 0)
    If hKeyHook = 0 Then MsgBox ("Keyboard hook error")
    hMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, App.hInstance, 0)
    If hMouseHook = 0 Then MsgBox ("Mouse hook error")
End Sub
Public Sub UnHook()
    If hKeyHook Then UnhookWindowsHookEx (hKeyHook): hKeyHook = 0
    If hMouseHook Then UnhookWindowsHookEx (hMouseHook): hMouseHook = 0
End Sub
' Процедура перехвата сообщений клавиатуры
Private Function LowLevelkbdProc(ByVal uCode As Long, ByVal wParam As Long, lParam As KBDLLHOOKSTRUCT) As Long
    If uCode = HC_ACTION Then
        Select Case wParam
        Case WM_KEYDOWN, WM_KEYUP, WM_SYSKEYDOWN, WM_SYSKEYUP
            frmMain.lstEvenst.AddItem KeyString(wParam) & _
                                      "KeyCode: " & lParam.VkCode & _
                                      " ScanCode: " & lParam.ScanCode & _
                                      IIf(lParam.flags And LLKHF_INJECTED, "(inj)", vbNullString)
            frmMain.lstEvenst.ListIndex = frmMain.lstEvenst.ListCount - 1
        End Select
    End If
    LowLevelkbdProc = CallNextHookEx(hKeyHook, uCode, wParam, lParam)
End Function
' Процедура перехвата сообщений мыши
Private Function LowLevelMouseProc(ByVal uCode As Long, ByVal wParam As Long, lParam As MSLLHOOKSTRUCT) As Long
    If uCode = HC_ACTION Then
        Select Case wParam
        Case WM_MOUSEMOVE
            frmMain.lstEvenst.AddItem "MouseMove: " & _
                                      "Coord: " & lParam.pt.x & ", " & lParam.pt.y & _
                                      IIf(lParam.flags And LLMHF_INJECTED, "(inj)", vbNullString)
            frmMain.lstEvenst.ListIndex = frmMain.lstEvenst.ListCount - 1
        Case WM_MOUSEWHEEL
            frmMain.lstEvenst.AddItem "MouseWheel: " & _
                                      "Coord: " & lParam.pt.x & ", " & lParam.pt.y & _
                                      " Dir: " & IIf(lParam.mouseData > 0, "Forward", "Backward") & _
                                      IIf(lParam.flags And LLMHF_INJECTED, "(inj)", vbNullString)
            frmMain.lstEvenst.ListIndex = frmMain.lstEvenst.ListCount - 1
        Case Else
            frmMain.lstEvenst.AddItem MouseString(wParam) & _
                                      " Coord: " & lParam.pt.x & ", " & lParam.pt.y & _
                                      IIf(lParam.flags And LLMHF_INJECTED, "(inj)", vbNullString)
            frmMain.lstEvenst.ListIndex = frmMain.lstEvenst.ListCount - 1
        End Select
    End If
    LowLevelMouseProc = CallNextHookEx(hMouseHook, uCode, wParam, lParam)
End Function
Private Function MouseString(WH As Long) As String
    Select Case WH
    Case WM_LBUTTONDOWN: MouseString = "MouseLButtonDown:"
    Case WM_LBUTTONUP: MouseString = "MouseLButtonUp:"
    Case WM_RBUTTONDOWN: MouseString = "MouseRButtonDown:"
    Case WM_RBUTTONUP: MouseString = "MouseRButtonUp:"
    Case WM_MBUTTONDOWN: MouseString = "MouseMButtonDown:"
    Case WM_MBUTTONUP: MouseString = "MouseMMuttonUp:"
    End Select
End Function
Private Function KeyString(WH As Long) As String
    Select Case WH
    Case WM_KEYDOWN: KeyString = "KeyDown:"
    Case WM_KEYUP: KeyString = "KeyUp:"
    Case WM_SYSKEYDOWN: KeyString = "KeySysDown:"
    Case WM_SYSKEYUP: KeyString = "KeySysUp:"
    End Select
End Function
Форма для теста:
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
Option Explicit
 
Private Sub cmdRemoveHook_Click()
    UnHook
End Sub
Private Sub cmdSetHook_Click()
    Hook
End Sub
Private Sub Form_Unload(Cancel As Integer)
    UnHook
End Sub
Миниатюры
Нажмите на изображение для увеличения
Название: Безымянный.png
Просмотров: 485
Размер:	34.1 Кб
ID:	2014  
Вложения
Тип файла: rar SmallKeylogger.rar (2.5 Кб, 494 просмотров)
Размещено в Без категории
Показов 14072 Комментарии 6
Всего комментариев 6
Комментарии
  1. Старый комментарий
    Большое спасибо, очень помогло
    Запись от brifing размещена 28.01.2014 в 22:08 brifing вне форума
  2. Старый комментарий
    Аватар для Bati4eli
    Анатолий! Спасибо огромное!
    Всё наглядно и просто!

    А можно ли не просто код клавиши получить, а именно тот символ который вводится в зависимости от текущей раскладки клавиатуры?
    Запись от Bati4eli размещена 21.05.2015 в 09:41 Bati4eli вне форума
    Обновил(-а) Bati4eli 21.05.2015 в 09:46
  3. Старый комментарий
    Цитата:
    Сообщение от Bati4eli Просмотреть комментарий
    Анатолий! Спасибо огромное!
    Всё наглядно и просто!

    А можно ли не просто код клавиши получить, а именно тот символ который вводится в зависимости от текущей раскладки клавиатуры?
    Да можно. Подключаешься к очереди ввода нужного потока, получашь раскладку и далее с помощью ToAsciiEx получаешь символ.
    Запись от The trick размещена 11.07.2015 в 00:20 The trick вне форума
  4. Старый комментарий
    Привет. Я немного исследовал твоё решение. Целью было узнать, каким образом запретить некоторые события при условии, что мышь имитируется. Например, имитацию(inj) видно если другая программа создаёт mouse_event. А также видно, если пользоваться компьютером через TeamViewer - там все действия с (inj). Я добавил на форму кнопку, чтобы _Click обрабатывалось только при нажатии мышью, а не от mouse_event. Такой способ работает и кнопка не нажимается от эмуляции.

    В модуль я добавил такие строки:

    В объявление:
    Visual Basic
    1
    
    Public Emul As Boolean
    В функцию LowLevelMouseProc я добавил условие:
    Visual Basic
    1
    2
    3
    4
    5
    
        If (lParam.flags And LLMHF_INJECTED) = 1 Then
           Emul = True
         Else
           Emul = False
        End If
    На саму форму поставил кнопку:
    Visual Basic
    1
    2
    3
    
    Private Sub Command1_Click()
       If Not Emul Then MsgBox "НЕ эмулятор"
    End Sub
    Потом встал вопрос. Как сделать так, чтобы не только кнопка не работала, а мышь не двигалась на запрещённом приложении, если MouseMove порождается эмуляцией? Ну, например, как в одном из антивирусников. Из TeamViewer им нельзя управлять, т.к. курсор просто не входит в окно программы. Я поначалу подумал в сторону GetClipCursor. Но вряд ли это подходящий вариант. Вариант с SetCursorPos при достижении границ окна тоже не очень. Курсор будет дрожать при множественных попытках переместиться к границе окна.

    Не подскажешь, какие ещё варианты можно обдумать?
    Запись от CharlyChaplin размещена 08.09.2017 в 12:05 CharlyChaplin вне форума
  5. Старый комментарий
    Добрый день!

    Расширил ваш код под 64bit Excel, но происходит экстренное завершение Excel при выставлении brek point на функции LowLevelkbdProc, можете помочь разобраться в чем причина ?
    Код:
    Visual Basic
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    
    Option Explicit
     
    ' Модуль для перехвата событий ввода мыши и клавиатуры
    ' © Кривоус Анатолий Анатольевич (The trick), 2014
     
    Private Type KBDLLHOOKSTRUCT
        VkCode As Long
        ScanCode As Long
        flags As Long
        time As Long
        dwExtraInfo As Long
    End Type
     
    #If Win64 Then
        Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As LongPtr, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As LongPtr) As LongPtr
        Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As LongPtr, ByVal wParam As Integer, lParam As Any) As LongPtr
        Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr
    #Else
        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 Integer, lParam As Any) As Long
        Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
    #End If
     
    Private Const WH_KEYBOARD_LL = 13
    Private Const HC_ACTION = 0
    Private Const LLKHF_INJECTED = &H10
    Private Const WM_KEYDOWN As Long = &H100
    Private Const WM_KEYUP As Long = &H101
    Private Const WM_SYSKEYDOWN As Long = &H104
    Private Const WM_SYSKEYUP As Long = &H105
     
    Dim mhWndVBE As LongPtr
     
    Dim hKeyHook As LongPtr, hMouseHook As LongPtr
     
    Public Sub Hook()
        hKeyHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf LowLevelkbdProc, Application.HinstancePtr, 0)
        If hKeyHook = 0 Then MsgBox ("Keyboard hook error")
    End Sub
    Public Sub UnHook()
        If hKeyHook Then UnhookWindowsHookEx (hKeyHook): hKeyHook = 0
    End Sub
    ' Процедура перехвата сообщений клавиатуры
    Private Function LowLevelkbdProc(ByVal uCode As LongPtr, ByVal wParam As Long, lParam As KBDLLHOOKSTRUCT) As LongPtr
        If uCode = HC_ACTION Then
            Select Case wParam
            Case WM_KEYDOWN, WM_KEYUP, WM_SYSKEYDOWN, WM_SYSKEYUP
                Debug.Print KeyString(wParam) & _
                            "KeyCode: " & lParam.VkCode & _
                            " ScanCode: " & lParam.ScanCode & _
                            IIf(lParam.flags And LLKHF_INJECTED, "(inj)", vbNullString)
            End Select
        End If
        LowLevelkbdProc = CallNextHookEx(hKeyHook, uCode, wParam, lParam)
    End Function
     
    Private Function KeyString(WH As Long) As String
        Select Case WH
        Case WM_KEYDOWN: KeyString = "KeyDown:"
        Case WM_KEYUP: KeyString = "KeyUp:"
        Case WM_SYSKEYDOWN: KeyString = "KeySysDown:"
        Case WM_SYSKEYUP: KeyString = "KeySysUp:"
        End Select
    End Function
    Запись от art1289 размещена 07.08.2019 в 09:22 art1289 вне форума
  6. Старый комментарий
    Доброго времени суток
    Столкнулся с бедой не могу получить Хэндд и соответсвенно содержимое дочернего окна в Windows 10 используя приведенный код. Такое ощущение что выводится картинка - по любому месту кликаешь опредеяется только хэндл родительского окна.
    Исследуемое ПО одно и тоже но на разных системах. В XP находит в 10 нет
    Запись от Newzero размещена 03.09.2020 в 21:14 Newzero вне форума
 
КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2021, vBulletin Solutions, Inc.