Установить хук на указанное приложение

[salieri]

Здравствуйте! Написал программу, которая устанавливает хук на своё приложение. Теперь хочу по аналогии сделать установку хука на другое приложение. Всё, что необходимо для начала - это отслеживать изменение размера окна, свёрнуто оно или развёрнуто, не ушёл ли с него фокус.

Попытался через CreateProcess сделать, но ничего не вышло.
Вообще, необходимо любое приложение "хукать" (не только через CreateProcess), hWnd приложений все известны, как получить их hInstance и ThreadID я не знаю.


Вопрос, как корректно вызвать эту функцию?

hHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf Hook_Func, proc_info.dwProcessID, proc_info.dwThreadId)

Если написать так, то всё работает идеально, только в рамках моего приложения, а мне нужно на чужое приложение поставить:

hHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf Hook_Func, App.hInstance, App.ThreadID)

Подскажите, пожалуйста, в чём ошибка у меня?

Модуль:

Option Explicit
 
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 UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal cb As Long)
Public Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal iCode As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Public Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
 
 
Public Const WH_CALLWNDPROC = 4
Public Const WM_COMMAND = &H111
Public Const NORMAL_PRIORITY_CLASS = &H20&
Public Const GW_HWNDNEXT = 2
 
 
Public Type STARTUPINFO
    cb As Long
    lpReserved As String
    lpDesktop As String
    lpTitle As String
    dwX As Long
    dwY As Long
    dwXSize As Long
    dwYSize As Long
    dwXCountChars As Long
    dwYCountChars As Long
    dwFillAttribute As Long
    dwFlags As Long
    wShowWindow As Integer
    cbReserved2 As Integer
    lpReserved2 As Long
    hStdInput As Long
    hStdOutput As Long
    hStdError As Long
End Type
 
 
Public Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadId As Long
End Type
 
 
Public Type CWPSTRUCT
lParam As Long
wParam As Long
message As Long
hWnd As Long
End Type
 
 
 
Public hHook As Long
Public proc_info As PROCESS_INFORMATION
 
 
 
Public Function StartHook()
hHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf Hook_Func, proc_info.dwProcessID, proc_info.dwThreadId)
End Function
 
Public Sub StopHook()
UnhookWindowsHookEx hHook
End Sub
 
Public Function Hook_Func(ByVal iCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 
Dim CWP As CWPSTRUCT
 
CopyMemory CWP, ByVal lParam, Len(CWP)
 
If CWP.message = WM_COMMAND Then
Debug.Print CWP.wParam
End If
 
Hook_Func = CallNextHookEx(hHook, iCode, wParam, lParam)
 
End Function
 
 
Public Function ProcIDFromWnd(ByVal hWnd As Long) As Long
 
Dim idProc As Long
 
GetWindowThreadProcessId hWnd, idProc
ProcIDFromWnd = idProc
 
End Function
 
 
Public Function hWndFromPID(ByVal hInstance As Long) As Long
 
Dim tempHwnd As Long
  
tempHwnd = FindWindow(vbNullString, vbNullString)
 
 
Do Until tempHwnd = 0
 
If GetParent(tempHwnd) = 0 Then
 
If hInstance = ProcIDFromWnd(tempHwnd) Then
hWndFromPID = tempHwnd
Exit Do
End If
 
End If
  
 
tempHwnd = GetWindow(tempHwnd, GW_HWNDNEXT)
  
Loop
  
End Function
 
 
Public Function ExecCmd(ByVal cmdline As String) As Long
 
Dim start As STARTUPINFO
Dim ret As Long
Dim hWndApp As Long
 
 
Dim x As Byte
 
x = 0
 
 
 
start.cb = Len(start)
 
ret = CreateProcess(0, cmdline, 0, 0, 1, NORMAL_PRIORITY_CLASS, 0, 0, start, proc_info)
 
 
RTR:
 
Sleep 50
 
 
hWndApp = hWndFromPID(proc_info.dwProcessID)
 
If hWndApp > 0 Then
 
ExecCmd = hWndApp
 
 
Else
 
 
If x = 5 Then
GoTo EXT
Else
x = x + 1
GoTo RTR
End If
 
 
End If
 
 
EXT:
      
ExecCmd = hWndApp
    
End Function

Форма:

Option Explicit
 
 
 
Private Sub Command1_Click()
 
Dim hWndApp As Long
 
hWndApp = ExecCmd(App.Path & "\1.exe")
If hWndApp > 0 Then StartHook
 
Me.Caption = hWndApp & Chr(32) & hHook
 
End Sub
 
 
Private Sub Command2_Click()
 
If hHook > 0 Then StopHook
CloseHandle proc_info.hProcess
 
End Sub
 
 
Private Sub Form_Unload(Cancel As Integer)
Command2_Click
End Sub

Прикреплённый файлhook.zip (5,35 Кбайт, скачиваний: 33)

[salieri]

похоже, нашёл подходящее решение без DLL и TLB, буду пробовать: https://wasm.in/threads/gotovye-proekty-na-vb6.31728/

[B.V.]

Цитата salieri @ 23.05.20, 15:50

Подскажите, пожалуйста, в чём ошибка у меня?

Для глобального хука нужна DLL. В разделе есть реализации native-DLL на VB6 от SCINER-а и TheTrik, возможно, даже от Хакера.
Поиск по "native DLL" и никам в помощь!

Добавлено 24.05.20, 04:34
А это с другого форума http://bbs.vbstreets.ru/viewtopic.php?f=15&t=34902

[salieri]

Всё получилось! Действительно, всё работает без *.DLL, *.TLB. Авторский исходник (автор TheTrick) прикладываю к сообщению.
Прикреплённый файлMessageLog.zip (25,19 Кбайт, скачиваний: 160)

Сообщение отредактировано: salieri - 09.06.20, 23:45