Внедрение в чужой процесс на VB6 (без DLL)

Option Explicit
 
' Модуль для внедрения в чужой процесс и подмены оконной процедуры, с целью получить все сообщения пересылемые окну
' © Кривоус Анатолий Анатольевич (The trick), 2014
 
 
' ******                  ******* **                                         *            **
'  *    *                 *  *  *  *                        *                              *
'  *    *                    *     *                        *                              *
'  *    * *** ***            *     * **    *****           ****   *** **   ***     *****   *  **
'  *****   *   *             *     **  *  *     *           *       **  *    *    *     *  *  *
'  *    *  *   *             *     *   *  *******           *       *        *    *        * *
'  *    *   * *              *     *   *  *                 *       *        *    *        ***
'  *    *   * *              *     *   *  *     *           *  *    *        *    *     *  *  *
' ******     *              ***   *** ***  *****             **   *****    *****   *****  **   **
'            *
'          **
 
Private Type MessageInfo                    ' Эту структуру передаем в качестве параметра нашему окну
    Msg As Long
    wParam As Long
    lParam As Long
End Type
Private Type TrickThreadData
    SrcWnd As Long                          ' Хендл сабклассируемого окна
    DesthWnd As Long                        ' Хендл окна frmSpy
    EventHandle As Long                     ' Хендл события, отвечающего за завершение потока
    AddrWindowProc As Long                  ' Адрес функции WindowProc в чужом процессе
    AddrStructure As Long                   ' Адрес этой структуры
    Msg As MessageInfo                      ' Для передачи указателя COPYDATASTRUCT
End Type
Private Type COPYDATASTRUCT
    dwData As Long
    cbData As Long
    lpData As Long
End Type
 
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function VirtualAllocEx Lib "kernel32.dll" (ByVal hProcess As Long, lpAddress As Any, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFreeEx Lib "kernel32.dll" (ByVal hProcess As Long, lpAddress As Any, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function CreateRemoteThread Lib "kernel32" (ByVal hProcess As Long, lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (src As Any, dst As Any) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CreateEvent Lib "kernel32" Alias "CreateEventA" (lpEventAttributes As Any, ByVal bManualReset As Long, ByVal bInitialState As Long, lpName As Any) As Long
Private Declare Function PulseEvent Lib "kernel32" (ByVal hEvent As Long) As Long
Private Declare Function DuplicateHandle Lib "kernel32" (ByVal hSourceProcessHandle As Long, ByVal hSourceHandle As Long, ByVal hTargetProcessHandle As Long, lpTargetHandle As Long, ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwOptions As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, lParam As Any) As Long
 
Private Const WM_COPYDATA = &H4A
Private Const GWL_WNDPROC = (-4)
Private Const DUPLICATE_SAME_ACCESS = &H2
Private Const PROCESS_ALL_ACCESS = &H1F0FFF
Private Const MEM_COMMIT = &H1000&
Private Const MEM_RESERVE = &H2000&
Private Const MEM_RELEASE = &H8000&
Private Const PAGE_EXECUTE_READWRITE = &H40&
Private Const INFINITE = -1&
 
Private Const Prop As String = "pInject"                    ' 7 символов + \0, итого 8 байт, вполне помещается в переменную типа Currency
Private Const PropCur As Currency = 3276038452689.5472@     ' Строка Prop в виде Currecy числа
 
Public hProcess As Long                                     ' Хендл процесса, в который внедряемся
Public hThread As Long                                      ' Хендл потока, который мы создадим в чужом процессе
Public TID As Long                                          ' Идентификатор этого потока
Public lpProc As Long                                       ' Адрес функции InjectionProc
Public Size As Long                                         ' Размер данных и кода, внедряемого в процесс
Public hEvent As Long                                       ' Описатель события в нашем процессе
 
Dim lpPrevWndProc As Long                                   ' Адрес оконной процедуры frmSpy (изначальный)
 
' Функция внедряет код в чужой процесс
Public Function Hook(hwnd As Long) As Boolean
    Dim Buf() As Byte, ret As Long, PID As Long, DupHandle As Long, nearWndProc As Long, _
        FuncOf() As Long, FuncAddr() As Long, hMod As Long, lpFunc As Long, i As Long, lpData As Long
        
    If hProcess Then Clear                   ' Если перехват был, то убираем
    GetWindowThreadProcessId hwnd, PID
    
    ' Инициализация словаря
    If modListView.Dic Is Nothing Then modListView.DicInit
    
    If PID Then hProcess = OpenProcess(PROCESS_ALL_ACCESS, False, PID) Else Exit Function
 
    ' Создаем событие для управления потоком
    hEvent = CreateEvent(ByVal 0, 1, 0, ByVal 0)
 
    If hEvent = 0 Then Clear: Exit Function
    ' Создаем дубликат описателя события для процесса
    If DuplicateHandle(GetCurrentProcess(), hEvent, hProcess, DupHandle, 0, False, DUPLICATE_SAME_ACCESS) = 0 Then Clear: Exit Function
 
    ' Определяем размер для внедренного кода
    lpData = AddrOf(AddressOf AddrOf) - AddrOf(AddressOf InjectionProc)
    ' Определяем относительное смещение функции WindowProc от данных
    nearWndProc = AddrOf(AddressOf AddrOf) - AddrOf(AddressOf WindowProc)
    ' Определяем размер данных и кода
    Size = lpData + 32
 
    ' Выделяем память в чужом процессе
    lpProc = VirtualAllocEx(hProcess, ByVal 0, Size, MEM_COMMIT Or MEM_RESERVE, PAGE_EXECUTE_READWRITE)
    If lpProc = 0 Then MsgBox "Error allocate memory", vbCritical: Clear: Exit Function
 
    ' Определяем смещения для псевдофункций API относительно начала данных
    ReDim FuncOf(9)
    FuncOf(0) = AddrOf(AddressOf myCopyMemory) - AddrOf(AddressOf InjectionProc)
    FuncOf(1) = AddrOf(AddressOf myCopyMemory2) - AddrOf(AddressOf InjectionProc)
    FuncOf(2) = AddrOf(AddressOf myCloseHandle) - AddrOf(AddressOf InjectionProc)
    FuncOf(3) = AddrOf(AddressOf myWaitForSingleObject) - AddrOf(AddressOf InjectionProc)
    FuncOf(4) = AddrOf(AddressOf mySetProp) - AddrOf(AddressOf InjectionProc)
    FuncOf(5) = AddrOf(AddressOf myGetProp) - AddrOf(AddressOf InjectionProc)
    FuncOf(6) = AddrOf(AddressOf myRemoveProp) - AddrOf(AddressOf InjectionProc)
    FuncOf(7) = AddrOf(AddressOf mySetWindowLong) - AddrOf(AddressOf InjectionProc)
    FuncOf(8) = AddrOf(AddressOf mySendMessage) - AddrOf(AddressOf InjectionProc)
    FuncOf(9) = AddrOf(AddressOf myCallWindowProc) - AddrOf(AddressOf InjectionProc)
 
    ' Определяем адреса API функций, для системных библиотек их образы спроецированы по одному и томуже адресу что и у нас
    ReDim FuncAddr(9)
    hMod = GetModuleHandle("kernel32")
    FuncAddr(0) = GetProcAddress(hMod, "RtlMoveMemory")
    FuncAddr(1) = FuncAddr(0)
    FuncAddr(2) = GetProcAddress(hMod, "CloseHandle")
    FuncAddr(3) = GetProcAddress(hMod, "WaitForSingleObject")
    hMod = GetModuleHandle("user32")
    FuncAddr(4) = GetProcAddress(hMod, "SetPropA")
    FuncAddr(5) = GetProcAddress(hMod, "GetPropA")
    FuncAddr(6) = GetProcAddress(hMod, "RemovePropA")
    FuncAddr(7) = GetProcAddress(hMod, "SetWindowLongA")
    FuncAddr(8) = GetProcAddress(hMod, "SendMessageA")
    FuncAddr(9) = GetProcAddress(hMod, "CallWindowProcA")
 
    ' Копируем код
    ReDim Buf(Size - 1)
    CopyMemory Buf(0), ByVal AddrOf(AddressOf InjectionProc), lpData
 
    ' Модифицируем код для вызова API вместо наших пустышек
    For i = 0 To UBound(FuncOf)
        Buf(FuncOf(i)) = &HE9                                                   ' JMP
        GetMem4 (FuncAddr(i) - FuncOf(i) - lpProc) - 5, Buf(FuncOf(i) + 1)      ' near (относительный прыжок на API функцию)
    Next
 
    ' Копируем данные
    GetMem4 hwnd, Buf(lpData)                                                   ' Хендл сабклассируемого окна
    GetMem4 frmSpy.hwnd, Buf(lpData + 4)                                        ' Хендл окна-приемника
    GetMem4 DupHandle, Buf(lpData + 8)                                          ' Хендл события
    GetMem4 lpProc + lpData - nearWndProc, Buf(lpData + 12)                     ' Адрес WindowProc в чужом процессе
    GetMem4 lpProc + lpData, Buf(lpData + 16)                                   ' Адрес этой структуры в чужом процессе
    
    ' Делаем инъекцию
    If WriteProcessMemory(hProcess, lpProc, Buf(0), Size, ret) Then
        If ret <> Size Then MsgBox "Error write process", vbCritical: Clear: Exit Function
        ' Запускаем код инъекции
        hThread = CreateRemoteThread(hProcess, ByVal 0, 0, lpProc, ByVal lpProc + Size - 32, 0, TID)
        If hThread = 0 Then MsgBox "Error create thread", vbCritical: Clear: Exit Function
    End If
    
    lpPrevWndProc = SetWindowLong(frmSpy.hwnd, GWL_WNDPROC, AddressOf SpyWindowProc)     ' Сабклассим наше окно
    
    Hook = True
End Function
 
' Удалить инъекцию
Public Sub Clear()
    If lpPrevWndProc Then
        SetWindowLong frmSpy.hwnd, GWL_WNDPROC, lpPrevWndProc       ' Убираем сабклассинг
        lpPrevWndProc = 0
    End If
    If hThread Then
        PulseEvent hEvent                                           ' Запускаем завершение потока
        WaitForSingleObject hThread, INFINITE                       ' Ждем завершения потока (замораживаемся)
        CloseHandle hThread                                         ' Закрываем описатель потока
        hThread = 0
    End If
    If lpProc Then
        Call VirtualFreeEx(hProcess, ByVal lpProc, 0, MEM_RELEASE)  ' Освобождаем выделенную память
    End If
    If hProcess Then
        CloseHandle hProcess                                        ' Закрываем описатель процесса
        hProcess = 0
    End If
    If hEvent Then
        CloseHandle hEvent                                          ' Закрываем описатель события (объект тоже удалится)
        hEvent = 0
    End If
End Sub
' Оконная процедура для отслеживания сообщений из нашего процесса
Private Function SpyWindowProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim CDS As COPYDATASTRUCT, Info As MessageInfo
    
    If Msg = WM_COPYDATA Then
        ' Получили сообщение из того процесса!!!
        CopyMemory CDS, ByVal lParam, Len(CDS)
        CopyMemory Info, ByVal CDS.lpData, CDS.cbData
        ItemAdd modListView.GetMessageName(Info.Msg), Info.wParam, Info.lParam
    End If
    
    ' Обрабатываем как и раньше
    SpyWindowProc = CallWindowProc(lpPrevWndProc, hwnd, Msg, wParam, ByVal lParam)
End Function
 
' Данный код выполняется в АП чужого процесса, поэтому он не имеет понятия ни о каких глобальных или локальных переменных
' уровня этого модуля, единственная область памяти с которой он может работать передаеться ему указателем на структуру
' TrickThreadData, который в последствии сохраняется в свойстве окна 'pInject'. Вызов наших функций, ведет к перенапрвлению
' к соответствующим API функциям. Здесь выполняется код, который вообще не использует рантайм. Для использования функций
' рантайма (сейчас о функциях которые не требуют инициализацию контекста потока), нужно его предварительно загрузить, через
' LoadLibrary() и получить адреса функций через GetProcAddress(). Все символьные имена и переменные, нужно хранить в
' в выделенной для этого предварительно памяти. Так что обращение к любой глобальной переменной или константе
' (пример s$="VB6 best language") может вызвать ошибку доступа
 
' \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
' Процедура, выполняемая в чужом процессе, передаем ей указатель на данные
Private Sub InjectionProc(Dat As TrickThreadData)
    Dim lpOldProc As Long
    ' Мы в чужом процессе ))
    mySetProp Dat.SrcWnd, PropCur, Dat.AddrStructure                         ' Устанавливаем окну свойство с указателем на данные
    lpOldProc = mySetWindowLong(Dat.SrcWnd, GWL_WNDPROC, Dat.AddrWindowProc) ' Устанавливаем окну новый оконный обработчик
    ' Вместо нового адреса процедуры пишем старое
    Dat.AddrWindowProc = lpOldProc
    ' Замораживаем поток
    myWaitForSingleObject Dat.EventHandle, INFINITE
    ' Поток разморожен, значит надо возвращать все на место
    mySetWindowLong Dat.SrcWnd, GWL_WNDPROC, Dat.AddrWindowProc
    myRemoveProp Dat.SrcWnd, PropCur
    ' Закрываем описатель события
    myCloseHandle Dat.EventHandle
    ' Все поток закончен, теперь Clear разморозится и очистит занимаемую память
End Sub
 
' Прцедуры вызова соответствующих API c помощью сплайсинга
Private Function myCopyMemory(dst As TrickThreadData, ByVal src As Long, ByVal Length As Long) As Long
    myCopyMemory = -1
End Function
Private Function myCopyMemory2(ByVal dst As Long, src As TrickThreadData, ByVal Length As Long) As Long
    myCopyMemory2 = -2
End Function
Private Function mySetProp(ByVal hwnd As Long, ByRef Name As Currency, ByVal Value As Long) As Long
    mySetProp = -3
End Function
Private Function myGetProp(ByVal hwnd As Long, ByRef Name As Currency) As Long
    myGetProp = -4
End Function
Private Function myRemoveProp(ByVal hwnd As Long, ByRef Name As Currency) As Long
    myRemoveProp = -5
End Function
Private Function mySetWindowLong(ByVal hwnd As Long, ByVal Index As Long, ByVal Data As Long) As Long
    mySetWindowLong = -6
End Function
Private Function myWaitForSingleObject(ByVal hEvent As Long, ByVal Millisecond As Long) As Long
    myWaitForSingleObject = -7
End Function
Private Function mySendMessage(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, lParam As COPYDATASTRUCT) As Long
    mySendMessage = -8
End Function
Private Function myCallWindowProc(ByVal addr As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    myCallWindowProc = -9
End Function
Private Function myCloseHandle(ByVal Handle As Long) As Long
    myCloseHandle = -10
End Function
' Оконная функция, которая будет работать в чужом процессе
Private Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim lpDat As Long, Dat As TrickThreadData, CDS As COPYDATASTRUCT
    
    lpDat = myGetProp(hwnd, PropCur)
 
    myCopyMemory Dat, lpDat, Len(Dat)                   ' Копируем параметры
    
    ' Устанавливаем параметры сообщения
    Dat.Msg.Msg = uMsg
    Dat.Msg.wParam = wParam
    Dat.Msg.lParam = lParam
    
    myCopyMemory2 lpDat, Dat, Len(Dat)                  ' Копируем параметры обратно
    
    CDS.cbData = Len(Dat.Msg)
    CDS.lpData = lpDat + 20                             ' Смещение структуры MessageInfo, относительно данных
    
    ' Отправляем нашему окну уведомление
    mySendMessage Dat.DesthWnd, WM_COPYDATA, hwnd, CDS
    
    ' Вызываем процедуру по умолчанию
    WindowProc = myCallWindowProc(Dat.AddrWindowProc, hwnd, uMsg, wParam, lParam)
End Function
' \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
' Эта функция также служит маркером конца функции и в процесс не копируется
Private Function AddrOf(Value As Long) As Long
    AddrOf = Value
End Function

Option Explicit
 
' Модуль для получения окна под курсором (с учетом Z-порядка)
' © Кривоус Анатолий Анатольевич (The trick), 2014
 
Private Type Point
    x As Long
    y As Long
End Type
 
Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Declare Function WindowFromPoint Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As Any) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal ptx As Long, ByVal pty As Long) As Long
Private Declare Function PtInRegion Lib "gdi32" (ByVal hRgn As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
 
Private Const WS_EX_MDICHILD As Long = &H40&
Private Const WS_CHILD As Long = &H40000000
Private Const GWL_STYLE As Long = (-16)
Private Const GWL_EXSTYLE As Long = (-20)
Private Const GW_CHILD As Long = 5
Private Const GW_HWNDPREV As Long = 3
Private Const GW_HWNDLAST As Long = 1
 
' Получить хендл окна исходя из позиции курсора
Public Function GetWindowFromCursorPos() As Long
    Dim pt As Point, PID As Long, TID As Long, hwnd As Long, hWndParent As Long
    
    GetCursorPos pt
    hWndParent = WindowFromPoint(pt.x, pt.y)
 
    TID = GetWindowThreadProcessId(hWndParent, PID)
    If App.ThreadID = TID And GetCurrentProcessId() = PID Then Exit Function        ' Игнорируем окна нашего приложения
 
    hwnd = EnumWindowZOrder(hWndParent, pt, True)                                   ' Перебираем все дочерние окна
    
    Do While hWndParent <> hwnd And hwnd
        DoEvents
        hWndParent = EnumWindowZOrder(hwnd, pt, False)                              ' Перебераем все сестринские окна
        hwnd = EnumWindowZOrder(hWndParent, pt, True)                               ' Пока у него есть дети
    Loop
 
    If (GetWindowLong(hWndParent, GWL_STYLE) And WS_CHILD) Then                     ' Возвращаем если окно дочернее
        GetWindowFromCursorPos = hWndParent
    ElseIf (GetWindowLong(hWndParent, GWL_EXSTYLE) And WS_EX_MDICHILD) = 0 Then
        GetWindowFromCursorPos = hWndParent
    Else
        GetWindowFromCursorPos = EnumWindowZOrder(hWndParent, pt, False)
    End If
 
End Function
' Точка внутри окна
Private Function PtInWindow(hwnd As Long, x As Long, y As Long) As Boolean
    Dim RC As RECT
    GetWindowRect hwnd, RC
    PtInWindow = PtInRect(RC, x, y)
End Function
' Перечисление окон и возврат окна по координатам
Private Function EnumWindowZOrder(ByVal hwnd As Long, pt As Point, Optional IsParent As Boolean) As Long
    Dim hRgn As Long
    
    hRgn = CreateRectRgn(0, 0, 0, 0)
    
    If IsParent Then hwnd = GetWindow(hwnd, GW_CHILD)
 
    hwnd = GetWindow(hwnd, GW_HWNDLAST)
    
    Do While hwnd
        DoEvents
        If IsWindowVisible(hwnd) And PtInWindow(hwnd, pt.x, pt.y) Then
            If GetWindowRgn(hwnd, hRgn) = 0 Then Exit Do
            If PtInRegion(hRgn, pt.x, pt.y) Then Exit Do
        End If
        hwnd = GetWindow(hwnd, GW_HWNDPREV)
    Loop
    
    DeleteObject hRgn
    EnumWindowZOrder = hwnd
End Function

Option Explicit
 
' Дополнительный модуль для работы с SysListView32
' © Кривоус Анатолий Анатольевич (The trick), 2014
 
' Стандартный ListViewWndClass перерисовывает всю клиентскую область при добавлении
' новой записи, либо при прокрутке из-за этого происходит неприятное мерцание, иногда
' даже полностью "белеет" фон. Для предотвращения такого поведения я решил использовать
' SysListView32, который ведет себя правильно при добавлении записей и прокрутке
' Также я использую в качестве идентификации сообщений коллекцию, с ключом - номером сообщения
' поэтому не поддерживаются одинаковые номера сообщений, т.к. я делал этот пример только
' ради демонстрации внедрения
 
Private Type LVITEM
    mask       As Long
    iItem      As Long
    iSubItem   As Long
    State      As Long
    stateMask  As Long
    pszText    As String
    cchTextMax As Long
    iImage     As Long
    lParam     As Long
    iIndent    As Long
End Type
Private Type LVCOLUMN
    mask As Long
    fmt As Long
    CX As Long
    pszText As String
    cchTextMax As Long
    iSubItem As Long
    iImage As Long
    iOrder As Long
End Type
Private Type tagInitCommonControlsEx
    dwSize As Long
    dwICC As Long
End Type
Private Declare Function InitCommonControlsEx Lib "comctl32" (ByRef TLPINITCOMMONCONTROLSEX As tagInitCommonControlsEx) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
 
Private Const ICC_WIN95_CLASSES = &HFF
Private Const WS_CHILD = &H40000000
Private Const WS_TABSTOP = &H10000
Private Const LVS_REPORT = &H1&
Private Const LVS_SINGLESEL = &H4&
Private Const WS_EX_CLIENTEDGE = &H200&
Private Const LVS_EX_FULLROWSELECT = &H20&
Private Const LVS_EX_GRIDLINES = &H1&
Private Const SW_SHOW = 5
 
Private Const LVM_FIRST = &H1000
Private Const LVM_INSERTCOLUMN = (LVM_FIRST + 27)
Private Const LVM_INSERTITEM = (LVM_FIRST + 7)
Private Const LVM_SETEXTENDEDLISTVIEWSTYLE = (LVM_FIRST + 54)
Private Const LVM_GETITEMCOUNT = (LVM_FIRST + 4)
Private Const LVM_ENSUREVISIBLE = (LVM_FIRST + 19)
Private Const LVM_SETITEMTEXTA = (LVM_FIRST + 46)
Private Const LVCF_WIDTH = &H2
Private Const LVCF_TEXT = &H4
Private Const LVIF_TEXT = &H1
 
Public hListView As Long                                                                        ' Хендл
Public Dic As Collection                                                                        ' Список сообщений
 
' Инициализация ListView
Public Sub InitListView()
    Dim ExStyle As Long
    Dim LVStyle As Long
    Dim Col As LVCOLUMN
    Dim CC As tagInitCommonControlsEx
    
    CC.dwSize = Len(CC)
    CC.dwICC = ICC_WIN95_CLASSES
    
    If InitCommonControlsEx(CC) = 0 Then MsgBox "Error InitCommonControlsEx": End
    
    ExStyle = WS_EX_CLIENTEDGE                                                                  ' Рамка у ListView
    LVStyle = WS_CHILD Or WS_TABSTOP Or LVS_REPORT Or LVS_SINGLESEL                             ' Стиль Report и единственный выбор
    
    hListView = CreateWindowEx(ExStyle, "SysListView32", vbNullString, LVStyle, 5, 5, 100, 100, frmSpy.hwnd, 0, App.hInstance, ByVal 0)
    
    If hListView = 0 Then MsgBox "Error creating ListView " & Err.LastDllError, vbCritical: End ' Если не удалось создать - нет смысла
                                                                                                ' продолжать работать
    
    SendMessage hListView, LVM_SETEXTENDEDLISTVIEWSTYLE, 0, _
                ByVal LVS_EX_FULLROWSELECT Or LVS_EX_GRIDLINES                                  ' Установка расширеных стилей:
                                                                                                ' выбор всей строки и сетка
    ' Вставляем колонки в ListView
    Col.mask = LVCF_TEXT Or LVCF_WIDTH
    Col.pszText = "№": Col.cchTextMax = Len(Col.pszText): Col.CX = 64
    SendMessage hListView, LVM_INSERTCOLUMN, 0, Col
    
    Col.pszText = "Message": Col.cchTextMax = Len(Col.pszText): Col.CX = 200
    SendMessage hListView, LVM_INSERTCOLUMN, 1, Col
    
    Col.pszText = "wParam": Col.cchTextMax = Len(Col.pszText): Col.CX = 100
    SendMessage hListView, LVM_INSERTCOLUMN, 2, Col
    
    Col.pszText = "lParam": Col.cchTextMax = Len(Col.pszText): Col.CX = 100
    SendMessage hListView, LVM_INSERTCOLUMN, 3, Col
    
    Call ShowWindow(hListView, SW_SHOW)                                                         ' Показываем окно
End Sub
' Уничтожение ListView
Public Sub DestroyListView()
    DestroyWindow hListView                                                                     ' Уничтожаем окно
    hListView = 0
End Sub
' Инициализация словаря
Public Sub DicInit()
    Dim fNum As Integer, s As String, key As String
    
    On Error GoTo Errorlabel
    
    fNum = FreeFile
    
    Open App.Path & "\WMList.txt" For Input As fNum
    
    Set Dic = New Collection
    
    Do Until EOF(fNum)
        Line Input #fNum, s
        key = "_" & Left$(s, 4)
        Dic.Add Mid$(s, 5), key
    Loop
    
    Close fNum
    
    Exit Sub
Errorlabel:
    MsgBox "Windows messages list loading error", vbExclamation
    Err.Clear
End Sub
' Добавить строку (без мерцания)
Public Function ItemAdd(ByVal Message As String, ByVal wParam As String, ByVal lParam As String) As Boolean
    Dim LV As LVITEM, i As Long
    
    i = SendMessage(hListView, LVM_GETITEMCOUNT, 0, ByVal 0&)
    
    With LV
      .pszText = i
      .iItem = i
      .cchTextMax = Len(.pszText)
      .mask = LVIF_TEXT
    End With
    
    SendMessage hListView, LVM_INSERTITEM, 0, LV
    LV.pszText = Message: LV.iSubItem = 1
    SendMessage hListView, LVM_SETITEMTEXTA, i, LV
    LV.pszText = wParam: LV.iSubItem = 2
    SendMessage hListView, LVM_SETITEMTEXTA, i, LV
    LV.pszText = lParam: LV.iSubItem = 3
    SendMessage hListView, LVM_SETITEMTEXTA, i, LV
    
    SendMessage hListView, LVM_ENSUREVISIBLE, i, ByVal True
End Function
' Возвращает имя сообщения по номеру
Public Function GetMessageName(ByVal Number As Long) As String
    On Error Resume Next
    Dim h As String
    
    h = "0000": Mid$(h, 5 - Len(Hex(Number))) = Hex(Number)
    GetMessageName = Dic.Item("_" & h)
    If Err.Number Then GetMessageName = h: Err.Clear
End Function

Option Explicit
 
' Форма frmSpy.frm
' © Кривоус Анатолий Анатольевич (The trick), 2014
' Работает вместе с modEnumWindow.mod, modInjection.mod, modListView.mod
 
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function SetROP2 Lib "gdi32" (ByVal hdc As Long, ByVal nDrawMode As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function GetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long) As Long
Private Declare Function IsZoomed Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function FrameRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateHatchBrush Lib "gdi32" (ByVal nIndex As Long, ByVal crColor As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
 
Private Const COLOR_WINDOWFRAME As Long = 6
Private Const HS_DIAGCROSS As Long = 5
Private Const SM_CXBORDER As Long = 5
Private Const SM_CYBORDER As Long = 6
Private Const SM_CXFRAME = 32
Private Const SM_CYFRAME = 33
Private Const R2_NOT As Long = 6
Private Const PS_INSIDEFRAME As Long = 6
Private Const NULL_BRUSH As Long = 5
 
Private Const ControlSpacing As Long = 5                                                        ' Расстояние между контролами
 
Dim hWndprev As Long                                                                            ' Хендл "захваченного" окна
Dim Pn As Long, Br As Long                                                                      ' Перо и кисть
 
' Установка позиции и размеров контролов в зависимости от размеров формы
Private Sub SetMetrics()
    Dim CsPx As Long, l As Long, t As Long, w As Long, h As Long
 
    w = Me.ScaleWidth - ControlSpacing * 2
    h = Me.ScaleHeight - ControlSpacing * 3 - cmdPick.Height
    
    cmdPick.Move (Me.ScaleWidth - cmdPick.Width - cmdStop.Width - ControlSpacing) \ 2, _
                 ControlSpacing * 2 + h
    cmdStop.Move cmdPick.Left + cmdPick.Width, _
                      cmdPick.Top
                      
    MoveWindow modListView.hListView, ControlSpacing, _
                         ControlSpacing, _
                         w, h, True
End Sub
 
' Нажали на кнопку - начинаем поиск
Private Sub cmdPick_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    hWndprev = 0
    cmdPick.Caption = "Drop on window"
End Sub
' Перемещение кнопки над окнами
Private Sub cmdPick_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If modInjection.hThread = 0 Then MarkWindow
End Sub
' Отпустили кнопку
Private Sub cmdPick_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    MarkWindow True
    cmdPick.Caption = "Drag on window"
    If hWndprev Then
        modInjection.Clear
        cmdPick.Enabled = Not modInjection.Hook(hWndprev)
    End If
End Sub
Private Sub cmdStop_Click()
    modInjection.Clear               ' Удаляем инъекцию
    hWndprev = 0
    cmdPick.Enabled = True
End Sub
Private Sub Form_Load()
    modListView.InitListView
    Pn = CreatePen(PS_INSIDEFRAME, GetSystemMetrics(SM_CXBORDER) * 3, vbBlack)
    Br = CreateHatchBrush(HS_DIAGCROSS, GetSysColor(COLOR_WINDOWFRAME))
End Sub
 
' Помечаем окно рамкой
Private Sub MarkWindow(Optional Cancel As Boolean)
    Dim hWndFp As Long, Buf As String, l As Long
 
    If Cancel And hWndprev Then DrawFrame hWndprev: Exit Sub    ' Это когда отпускаем кнопку, чтобы отменить изменения
    
    hWndFp = modEnumWindow.GetWindowFromCursorPos               ' Получаем окно под курсором
    
    If hWndFp <> hWndprev Then
        If hWndFp Then
            Buf = String(256, 0)
            l = GetClassName(hWndFp, Buf, 255)
            If l Then Buf = Left(Buf, l)
            Me.Caption = Hex(hWndFp) & " Class = '" & Buf & "' "
            DrawFrame hWndFp
        Else
            Me.Caption = "Message log by the trick"
        End If
        If hWndprev Then DrawFrame hWndprev
    End If
    
    hWndprev = hWndFp
End Sub
' Рисует рамку у окна
Private Sub DrawFrame(lhWnd As Long)
    Dim hDCWnd As Long, RC As RECT, oPn As Long, oBr As Long, _
        hRgn As Long, SzX As Long, SzY As Long
 
    hDCWnd = GetWindowDC(lhWnd)
    If hDCWnd = 0 Then Exit Sub
    SetROP2 hDCWnd, R2_NOT
    oPn = SelectObject(hDCWnd, Pn)
    oBr = SelectObject(hDCWnd, GetStockObject(NULL_BRUSH))
    
    hRgn = CreateRectRgn(0, 0, 0, 0)
    SzX = GetSystemMetrics(SM_CXBORDER) * 3
    SzY = GetSystemMetrics(SM_CYBORDER) * 3
    
    If GetWindowRgn(lhWnd, hRgn) Then
        FrameRgn hDCWnd, hRgn, oBr, SzX, SzY
    Else
        GetWindowRect lhWnd, RC
        If IsZoomed(lhWnd) Then
            RC.Left = GetSystemMetrics(SM_CXFRAME)
            RC.Top = GetSystemMetrics(SM_CYFRAME)
            RC.Right = RC.Right + RC.Left
            RC.Bottom = RC.Bottom + RC.Top
        End If
        Rectangle hDCWnd, 0, 0, RC.Right - RC.Left, RC.Bottom - RC.Top
    End If
    
    SelectObject hDCWnd, oBr
    SelectObject hDCWnd, oPn
    ReleaseDC lhWnd, hDCWnd
End Sub
Private Sub Form_Resize()
    If Me.ScaleHeight > (cmdPick.Height + ControlSpacing * 3) Then SetMetrics
End Sub
Private Sub Form_Unload(Cancel As Integer)
    Call cmdStop_Click
    DeleteObject Pn
    DeleteObject Br
    DestroyListView
End Sub