Многопоточность в VB6 часть 3

Автор обещает много интересных штучек.

Модератор: The trick

The trick
Постоялец
Постоялец
 
Сообщения: 774
Зарегистрирован: 26.06.2010 (Сб) 23:08

Многопоточность в VB6 часть 3

Сообщение The trick » 11.11.2014 (Вт) 16:49


Эта часть скорее больше о внедрении DLL чем о многопоточности как таковой, но т.к. DLL может работать в программах с различным числом потоков то я сделал эту часть как продолжение темы о многопоточности в VB6. В прошлой части я написал о возможности создания потока в DLL, и о методе создания нативной DLL на VB6. Также я написал о том, что такая DLL будет работать в любом приложении, но примера не привел. В этой части мы напишем DLL которая будет выполняться в чужом 32-разрядном процессе и выполнять там наш код. В качестве примера сделаем приложение которое будет осуществлять сабклассинг окна в другом потоке и передавать в наше приложение сообщения, которые мы сможем обработать. Напишу сразу - DLL только для примера и не предназначена для работы в приложениях, т.к. имеются недостатки которые в качестве экономии кода я не устранял.
Я решил сделать 3 случая использования:
  • Ограничение минимального размера перекрывающегося окна.
  • Отслеживания нажатий/отпусканий кнопок мыши в окне.
  • Лог сообщений.
Итак, сначала нужно придумать механизм взаимодействия между процессами. Я решил пойти следующим путем:
  1. Для обмена данными между приложениями будем использовать проецированный в память файл.
  2. Для передачи сообщения от процесса-"жертвы" нашему приложению, будем использовать новое зарегистрированное сообщение.
  3. Для уведомления о завершении сабклассинга передавать сообщение будем в другую сторону.
Теперь нужно продумать как осуществлять запуск. Ставим хук WH_GETMESSAGE на поток в котором содержится окно. Теперь наша DLL загрузится в АП процесса жертвы. В callback функции GetMsgProc при первом вызове будем инициализировать данные и устанавливать сабклассинг на нужное окно, для обмена как было сказано выше используем файл-маппинг. Итак код:
Код: Выделить всё
' modSubclassDLL.bas  - процедуры хука и сабклассинга
' © Кривоус Анатолий Анатольевич (The trick), 2014

Option Explicit

' Эту структуру мы будем прередавать между процессами через файловое представление
Public Type MsgData
    hWnd    As Long     ' Хендл сабклассируемого окна
    uMsg    As Long     ' Сообщение
    wParam  As Long     ' Параметры
    lParam  As Long     ' -
    return  As Long     ' Возвращаемое значение
    defCall As Long     ' Вызывать ли изначальную процедуру
End Type

Private Declare Function OpenFileMapping Lib "kernel32" Alias "OpenFileMappingW" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal lpName As Long) As Long
Private Declare Function OpenMutex Lib "kernel32" Alias "OpenMutexW" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal lpName As Long) As Long
Private Declare Function MapViewOfFile Lib "kernel32" (ByVal hFileMappingObject As Long, ByVal dwDesiredAccess As Long, ByVal dwFileOffsetHigh As Long, ByVal dwFileOffsetLow As Long, ByVal dwNumberOfBytesToMap As Long) As Long
Private Declare Function UnmapViewOfFile Lib "kernel32" (ByVal lpBaseAddress As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function ReleaseMutex Lib "kernel32" (ByVal hMutex 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 SendMessage Lib "user32" Alias "SendMessageW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropW" (ByVal hWnd As Long, ByVal lpString As Long, ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropW" (ByVal hWnd As Long, ByVal lpString As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropW" (ByVal hWnd As Long, ByVal lpString As Long) As Long
Private Declare Function GlobalAddAtom Lib "kernel32" Alias "GlobalAddAtomW" (ByVal lpString As Long) As Integer
Private Declare Function GlobalDeleteAtom Lib "kernel32" (ByVal nAtom As Integer) As Integer
Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageW" (ByVal lpString As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcW" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Const GWL_WNDPROC        As Long = (-4)
Private Const INFINITE           As Long = -1&
Private Const MUTEX_ALL_ACCESS   As Long = &H1F0001
Private Const FILE_MAP_READ      As Long = &H4
Private Const FILE_MAP_WRITE     As Long = &H2
Private Const WAIT_FAILED        As Long = -1&

Private WM_SENDMESSAGE   As Long    ' Наше сообщение для обмена с основной программой. Отсылая из текущего потока это сообщение
                                    ' в наше приложение (TestSubclassDLL), мы уведомляем приложение через SendMessage о том, что
                                    ' пришло новое сообщение, параметры которого записаны в файловое представление. Передавая из
                                    ' главного (TestSubclassDLL) приложения сюда это сообщение, мы уведомляем о том, что нужно
                                    ' снять сабклассинг и выполнить деинициализацию.
   
Dim hMutex      As Long     ' Описатель мьютекса для синхронизации чтения/записи общих данных
Dim hMap        As Long     ' Хендл файлового отображения
Dim lpShrdData  As Long     ' Адрес общих данных
Dim hWndServer  As Long     ' Хендл окна для приема и обработки сообщений
Dim hWndHook    As Long     ' Хендл сабклассируемого окна в этом процессе
Dim hHook       As Long     ' Хендл хука, для передачи в CallNextHookEx
Dim aPrevProc   As Integer  ' Атом имени свойства изначальной оконной процедуры
Dim init        As Boolean  ' Инициализирован ли сабклассинг
Dim disabled    As Boolean  ' Сабклассинг окончен.

' // Процедура хука
Public Function GetMsgProc(ByVal code As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim prevProc    As Long
    ' Если не инициализирован сабклассинг - инициализируем
    If Not (init Or disabled) Then
        ' Открываем проекцию
        hMap = OpenFileMapping(FILE_MAP_WRITE, False, StrPtr("TrickSubclassFileMap"))
        If hMap = 0 Then MsgBox "Невозможно открыть проекцию", vbCritical: Clear: Exit Function
        ' Проецируем
        lpShrdData = MapViewOfFile(hMap, FILE_MAP_WRITE, 0, 0, 0)
        CloseHandle hMap: hMap = 0
        If lpShrdData = 0 Then MsgBox "Невозможно отобразить представление", vbCritical: Clear: Exit Function
        ' Открываем синхронизирующий мьютекс
        hMutex = OpenMutex(MUTEX_ALL_ACCESS, False, StrPtr("TrickSubclassMutex"))
        If hMutex = 0 Then MsgBox "Невозможно отрыть мьютекс", vbCritical: Clear: Exit Function
        ' Регистрация сообщения
        WM_SENDMESSAGE = RegisterWindowMessage(StrPtr(WM_SENDMESSAGE))
        If WM_SENDMESSAGE = 0 Then MsgBox "Невозможно Зарегистрировать сообщение", vbCritical: Clear: Exit Function
        ' Добавляем/получаем атом для сохранения предыдущей оконной процедуры
        aPrevProc = GlobalAddAtom(StrPtr("prevProc"))
        If aPrevProc = 0 Then MsgBox "Невозможно добавить атом", vbCritical: Clear: Exit Function
        ' Захватываем мьютекс. Если например в главном приложении еще не произошел выход из SetWindowsHookEx, то
        ' еще неизвестен хендл хука, а т.к. у нас там уже захвачен этот мьютекс, то этот поток будет ждать пока
        ' мьютекс не освободится, что произойдет только после записи хендля хука в общую память и остальных данных
        If WaitForSingleObject(hMutex, INFINITE) = WAIT_FAILED Then MsgBox "Ошибка ожидания", vbCritical: Clear: Exit Function
        ' Получаем хендл окна, которое будет принимать сообщения
        GetMem4 ByVal lpShrdData, hWndServer
        ' Получаем хендл сабклассируемого окна
        GetMem4 ByVal lpShrdData + 4, hWndHook
        ' Получаем хендл хука
        GetMem4 ByVal lpShrdData + 8, hHook
        ' Освобождаем мьютекс
        ReleaseMutex hMutex
        ' Получаем адрес оконной процедуры и задаем новый
        prevProc = SetWindowLong(hWndHook, GWL_WNDPROC, AddressOf WndProc)
        If prevProc = 0 Then MsgBox "Невозможно заменить оконную процедуру", vbCritical: Clear: Exit Function
        ' Установка свойства окна
        SetProp hWndHook, CLng(aPrevProc) And &HFFFF&, prevProc
        ' Успех
        init = True
    End If
    ' Передаем на обработку другим процедурам
    GetMsgProc = CallNextHookEx(hHook, code, wParam, lParam)
End Function

' // Деинициализация
Public Sub Clear()
    If hMutex Then CloseHandle (hMutex): hMutex = 0
    If lpShrdData Then UnmapViewOfFile (lpShrdData): lpShrdData = 0
    If hWndHook Then RemoveProp hWndHook, CLng(aPrevProc) And &HFFFF&: hWndHook = 0
    If aPrevProc Then GlobalDeleteAtom (aPrevProc): aPrevProc = 0
    init = False
End Sub

' // Оконная процедура
Private Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim sendData    As MsgData
    Dim prevProc    As Long
    ' Проверяем не снятие ли сабклассинга
    If uMsg = WM_SENDMESSAGE Then
        ' Получаем предыдущий адрес процедуры
        prevProc = GetProp(hWnd, CLng(aPrevProc) And &HFFFF&)
        ' Устанавливаем его оконной процедуре
        SetWindowLong hWnd, GWL_WNDPROC, prevProc
        ' Очистка
        Clear
        ' Отключаем сабклассинг
        ' Возможна ситуация когда будет вызвана GetMsgProc, до того, как будет снят хук в главно приложении
        ' этот флаг предотвращает повторную инициализацию данных.
        disabled = True
        Exit Function
        ' Теперь из главного приложения будет вызвана UnhookWindowsHookEx и наша DLL будет выгружена из памяти.
    End If
    ' Формируем запрос
    sendData.hWnd = hWnd
    sendData.uMsg = uMsg
    sendData.wParam = wParam
    sendData.lParam = lParam
    sendData.defCall = True
    ' Захватываем мьютекс
    If WaitForSingleObject(hMutex, INFINITE) = WAIT_FAILED Then MsgBox "Ошибка ожидания", vbCritical: Clear: Exit Function
    CopyMemory ByVal lpShrdData + 12, sendData, Len(sendData)
    ' Освобождаем мьютекс
    ReleaseMutex hMutex
    ' Отправляем сообщение главному окну
    SendMessage hWndServer, WM_SENDMESSAGE, 0, ByVal 0
    ' Получаем результат обработки
    If WaitForSingleObject(hMutex, INFINITE) = WAIT_FAILED Then MsgBox "Ошибка ожидания", vbCritical: Clear: Exit Function
    CopyMemory sendData, ByVal lpShrdData + 12, Len(sendData)
    ' Освобождаем мьютекс
    ReleaseMutex hMutex
    ' Следует ли обрабатывать его дальше
    If sendData.defCall Then
        prevProc = GetProp(hWnd, CLng(aPrevProc) And &HFFFF&)
        WndProc = CallWindowProc(prevProc, sendData.hWnd, sendData.uMsg, sendData.wParam, sendData.lParam)
    Else
        WndProc = sendData.return
    End If
End Function

Разберем подробно код. В процедуре инициализации проверяем флаги инициализации и отключения сабклассинга. Если какой-либо True, то значит либо сабклассинг установлен, либо закончен. Иначе начинаем инициализацию. Первым делом открываем файл-маппинг и проецируем представление на АП процесса. Для избежания состояния гонки используем синхронизирующий объект мьютекс. Потом регистрируем сообщение WM_SENDMESSAGE для обмена в системе и получаем его номер. Для хранения адреса предыдущей оконной процедуры я решил использовать свойство окна, хотя можно было бы использовать и переменную модуля, т.к. за раз можно только перехватить только одно окно в этой реализации. Для ускоренного доступа к свойству я использую атом, поэтому регистрируем его с именем prevProc. Потом пытаемся захватить мьютекс. Когда это удается, то общие данные доступны только для этого потока, никакой другой поток не сможет что-то записать туда и мы избежим состояния гонки. Из файл-маппинга достаем нужные нам данные (хендл главного окна нашего приложения, хендл сабклассируемого окна и хендл хука, его нужно передать в CallNextHookEx). Позже освобождаем мьютекс, и устанавливаем адрес оконной процедуры на наш (сабклассируем окно). Теперь все сообщения предназначенные для окна пойдут в процедуру WndProc.
Разберем процедуру WndProc. Для начала разберем структуру файл-маппинга:
Изображение
Проверяем сообщение, если это наше зарегистрированное, то его может отправить только наше приложение при снятии сабклассинга, поэтому выполняем деинициализацию. Иначе формируем данные сообщения и, захватив мьютекс, пишем их в файл маппинг со смещения 0x0Ch (1210) и передаем их в главное окно нашего приложения для обработки. Т.к. мы используем SendMessage для передачи, выход из нее не произойдет пока мы в своем приложении не завершим обработку этого сообщения. При возврате проверяем флаг defCall, который отвечает пускать ли сообщение дальше в старую оконную процедуру или нет.
Теперь разберем главное приложение:
Модуль:
Код: Выделить всё
' modMain.bas - демонстрация работы многопоточности в NativeDLL на примере внедрения DLL и выполнению сабклассинга
' © Кривоус Анатолий Анатольевич (The trick), 2014

Option Explicit

' Соответствует из SubclassDLL
Public Type MsgData
    hwnd    As Long
    uMsg    As Long
    wParam  As Long
    lParam  As Long
    return  As Long
    defCall As Long
End Type

Public Type POINTAPI
    x   As Long
    y   As Long
End Type
Public Type MINMAXINFO
    ptReserved      As POINTAPI
    ptMaxSize       As POINTAPI
    ptMaxPosition   As POINTAPI
    ptMinTrackSize  As POINTAPI
    ptMaxTrackSize  As POINTAPI
End Type
Public Type RECT
    Left    As Long
    Top     As Long
    Right   As Long
    Bottom  As Long
End Type

Public Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Public Declare Function GetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long) As Long
Public Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public 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
Public Declare Function FrameRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Public Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Public Declare Function SetROP2 Lib "gdi32" (ByVal hdc As Long, ByVal nDrawMode As Long) As Long
Public Declare Function GetROP2 Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Public Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Public Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Public Declare Function CreateFileMapping Lib "kernel32" Alias "CreateFileMappingW" (ByVal hFile As Long, lpFileMappigAttributes As Any, ByVal flProtect As Long, ByVal dwMaximumSizeHigh As Long, ByVal dwMaximumSizeLow As Long, ByVal lpName As Long) As Long
Public Declare Function MapViewOfFile Lib "kernel32" (ByVal hFileMappingObject As Long, ByVal dwDesiredAccess As Long, ByVal dwFileOffsetHigh As Long, ByVal dwFileOffsetLow As Long, ByVal dwNumberOfBytesToMap As Long) As Long
Public Declare Function UnmapViewOfFile Lib "kernel32" (ByVal lpBaseAddress As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexW" (lpMutexAttributes As Any, ByVal bInitialOwner As Long, ByVal lpName As Long) As Long
Public Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExW" (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 Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As Long) As Long
Public Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Public Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Public Declare Function GetMem4 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
Public Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Public Declare Function ReleaseMutex Lib "kernel32" (ByVal hMutex As Long) As Long
Public Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageW" (ByVal lpString As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcW" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Public Const GWL_WNDPROC            As Long = (-4)
Public Const ERROR_ALREADY_EXISTS   As Long = 183&
Public Const INVALID_HANDLE_VALUE   As Long = -1
Public Const PAGE_READWRITE         As Long = &H4&
Public Const FILE_MAP_WRITE         As Long = &H2
Public Const INFINITE               As Long = -1&
Public Const WAIT_FAILED            As Long = -1&
Public Const WH_GETMESSAGE          As Long = 3
Public Const PROCESS_VM_OPERATION   As Long = &H8&
Public Const PROCESS_VM_READ        As Long = &H10&
Public Const PROCESS_VM_WRITE       As Long = &H20&
Public Const WM_GETMINMAXINFO       As Long = &H24
Public Const WHITE_BRUSH            As Long = 0
Public Const R2_XORPEN              As Long = 7
Public Const NULLREGION             As Long = 1
Public Const WM_LBUTTONDOWN         As Long = &H201&
Public Const WM_LBUTTONUP           As Long = &H202&

Public WM_SENDMESSAGE   As Long ' Наше сообщение
Public hProcess         As Long ' Хендл процесса, в котором стоит хук

Dim hMutex      As Long ' Мьютекс, для синхронизации записи и чтения
Dim lpShrdData  As Long ' Адрес общей памяти (доступной обоим процессам)
Dim hLib        As Long ' Хендл SubclassDLL
Dim lpProc      As Long ' Адрес GetMsgProc
Dim hHook       As Long ' Хендл хука
Dim TID         As Long ' ИД потока
Dim PID         As Long ' ИД процесса
Dim hMap        As Long ' Хендл проекции
Dim lpPrevProc  As Long ' Адрес изначальной оконной процедуры frmMain

' // Инициализация
Public Function Initialize() As Boolean
    ' Создаем мьютекс для синхронизации
    hMutex = CreateMutex(ByVal 0&, 0, StrPtr("TrickSubclassMutex"))
    If hMutex = 0 Then MsgBox "Невозможно создать мьютекс": Clear: Exit Function
    If Err.LastDllError = ERROR_ALREADY_EXISTS Then MsgBox "Один экземпляр уже запущен": Clear: Exit Function
    ' Создаем проекцию
    hMap = CreateFileMapping(INVALID_HANDLE_VALUE, ByVal 0&, PAGE_READWRITE, 0, 100, StrPtr("TrickSubclassFileMap"))
    If hMap = 0 Then MsgBox "Невозможно создать проекцию": Clear: Exit Function
    ' Проецируем
    lpShrdData = MapViewOfFile(hMap, FILE_MAP_WRITE, 0, 0, 0)
    If lpShrdData = 0 Then MsgBox "Невозможно отобразить представление", vbCritical: Clear: Exit Function
    ' Регистрация сообщения
    WM_SENDMESSAGE = RegisterWindowMessage(StrPtr(WM_SENDMESSAGE))
    If WM_SENDMESSAGE = 0 Then MsgBox "Невозможно Зарегистрировать сообщение", vbCritical: Clear: Exit Function
    ' Сабклассинг нашего окна для приема сообщений
    lpPrevProc = SetWindowLong(frmMain.hwnd, GWL_WNDPROC, AddressOf WndProc)
    ' Загружаем DLL
    hLib = LoadLibrary(StrPtr("..\SubclassDLL\SubclassDLL"))
    If hLib = 0 Then MsgBox "Невозможно загрузить модуль": ReleaseMutex hMutex: Exit Function
    lpProc = GetProcAddress(hLib, "GetMsgProc")
    If lpProc = 0 Then MsgBox "Невозможно найти функцию GetMsgProc": ReleaseMutex hMutex: Exit Function
    Initialize = True
End Function

' // Деинициализация
Public Sub Clear()
    If hMap Then CloseHandle (hMap)
    If hMutex Then CloseHandle (hMutex)
    If lpShrdData Then UnmapViewOfFile (lpShrdData)
    If hLib Then FreeLibrary (hLib)
    If lpPrevProc Then SetWindowLong frmMain.hwnd, GWL_WNDPROC, lpPrevProc
    If hProcess Then CloseHandle (hProcess)
End Sub

' // Установить сабклассинг
Public Function StartSubclass(ByVal hwnd As Long) As Long
    ' Получаем идентификатор потока
    TID = GetWindowThreadProcessId(hwnd, PID)
    If TID = 0 Then MsgBox "Невозможно получить ИД потока": Exit Function
    ' Нельзя сабклассить свои окна, иначе может произойти рекурсия
    If TID = App.ThreadID Then MsgBox "Нельзя сабклассить свои окна": Exit Function
    ' Если был сабклассинг, то убираем
    StopSubclass hwnd
    ' Открываем процесс
    hProcess = OpenProcess(PROCESS_VM_OPERATION Or PROCESS_VM_WRITE Or PROCESS_VM_READ, 0, PID)
    If hProcess = 0 Then MsgBox "Невозможно открыть процесс": Exit Function
    ' Захватываем мьютекс
    If WaitForSingleObject(hMutex, INFINITE) = WAIT_FAILED Then MsgBox "Ошибка ожидания", vbCritical: Clear: Exit Function
    ' Ставим хук на прием сообщений в нужном потоке
    hHook = SetWindowsHookEx(WH_GETMESSAGE, lpProc, hLib, TID)
    If hHook = 0 Then MsgBox "Невозможно поставить хук": ReleaseMutex hMutex: Exit Function
    ' Записываем хендл окна приемника сообщений
    GetMem4 CLng(frmMain.hwnd), ByVal lpShrdData
    ' Записываем хендл сабклассируемого окна
    GetMem4 hwnd, ByVal lpShrdData + 4
    ' Записываем хендл хука
    GetMem4 hHook, ByVal lpShrdData + 8
    ' Освобождаем мьютекс, код в другом процессе теперь сможет читать эти данные
    ReleaseMutex hMutex
    StartSubclass = True
End Function

' // Снять сабклассинг
Public Function StopSubclass(ByVal hwnd As Long) As Long
    If hHook Then
        ' Отправляем окну наше сообщение, в другом процессе наш обработчик обработает его и снимет сабклассинг
        SendMessage hwnd, WM_SENDMESSAGE, 0, ByVal 0&
        ' Снимаем хук, в другом процессе библиотека выгружается
        UnhookWindowsHookEx (hHook): hHook = 0
        ' Закрываем описатель процесса
        CloseHandle hProcess: hProcess = 0
        StopSubclass = True
    End If
End Function

' // Оконная процедура
Private Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case uMsg
    Case WM_SENDMESSAGE
        Dim msg As MsgData
        ' Захватываем мьютекс, хотя можно и не ожидать, потому что поток все равно спит, т.к. был вызов SendMessage
        ' но если сабклассить несколько окон, то вызов обязателен
        If WaitForSingleObject(hMutex, INFINITE) = WAIT_FAILED Then MsgBox "Ошибка ожидания", vbCritical: Clear: Exit Function
        ' Копируем данные сообщения в переменную
        CopyMemory msg, ByVal lpShrdData + 12, Len(msg)
        ' Вызываем наш обработчик
        msg.return = frmMain.WndProc(msg.hwnd, msg.uMsg, msg.wParam, msg.lParam, msg.defCall)
        ' Копируем обратно
        CopyMemory ByVal lpShrdData + 12, msg, Len(msg)
        ' Освобождаем мьютекс
        ReleaseMutex hMutex
    Case Else
        WndProc = CallWindowProc(lpPrevProc, hwnd, uMsg, wParam, lParam)
    End Select
End Function

' // Список сообщений
Public Sub SetWMList(msgList() As String)
    ReDim msgList(&H38F)
    msgList(&H0) = "WM_NULL"
    msgList(&H1) = "WM_CREATE"
    msgList(&H2) = "WM_DESTROY"
    msgList(&H3) = "WM_MOVE"
    msgList(&H5) = "WM_SIZE"
    msgList(&H6) = "WM_ACTIVATE"
    msgList(&H7) = "WM_SETFOCUS"
    msgList(&H8) = "WM_KILLFOCUS"
    msgList(&HA) = "WM_ENABLE"
    msgList(&HB) = "WM_SETREDRAW"
    msgList(&HC) = "WM_SETTEXT"
    msgList(&HD) = "WM_GETTEXT"
    msgList(&HE) = "WM_GETTEXTLENGTH"
    msgList(&HF) = "WM_PAINT"
    msgList(&H10) = "WM_CLOSE"
    msgList(&H11) = "WM_QUERYENDSESSION"
    msgList(&H12) = "WM_QUIT"
    msgList(&H13) = "WM_QUERYOPEN"
    msgList(&H14) = "WM_ERASEBKGND"
    msgList(&H15) = "WM_SYSCOLORCHANGE"
    msgList(&H16) = "WM_ENDSESSION"
    msgList(&H18) = "WM_SHOWWINDOW"
    msgList(&H19) = "WM_CTLCOLOR"
    msgList(&H1A) = "WM_WININICHANGE"
    msgList(&H1B) = "WM_DEVMODECHANGE"
    msgList(&H1C) = "WM_ACTIVATEAPP"
    msgList(&H1D) = "WM_FONTCHANGE"
    msgList(&H1E) = "WM_TIMECHANGE"
    msgList(&H1F) = "WM_CANCELMODE"
    msgList(&H20) = "WM_SETCURSOR"
    msgList(&H21) = "WM_MOUSEACTIVATE"
    msgList(&H22) = "WM_CHILDACTIVATE"
    msgList(&H23) = "WM_QUEUESYNC"
    msgList(&H24) = "WM_GETMINMAXINFO"
    msgList(&H26) = "WM_PAINTICON"
    msgList(&H27) = "WM_ICONERASEBKGND"
    msgList(&H28) = "WM_NEXTDLGCTL"
    msgList(&H2A) = "WM_SPOOLERSTATUS"
    msgList(&H2B) = "WM_DRAWITEM"
    msgList(&H2C) = "WM_MEASUREITEM"
    msgList(&H2D) = "WM_DELETEITEM"
    msgList(&H2E) = "WM_VKEYTOITEM"
    msgList(&H2F) = "WM_CHARTOITEM"
    msgList(&H30) = "WM_SETFONT"
    msgList(&H31) = "WM_GETFONT"
    msgList(&H32) = "WM_SETHOTKEY"
    msgList(&H33) = "WM_GETHOTKEY"
    msgList(&H37) = "WM_QUERYDRAGICON"
    msgList(&H39) = "WM_COMPAREITEM"
    msgList(&H3D) = "WM_GETOBJECT"
    msgList(&H41) = "WM_COMPACTING"
    msgList(&H44) = "WM_COMMNOTIFY"
    msgList(&H46) = "WM_WINDOWPOSCHANGING"
    msgList(&H47) = "WM_WINDOWPOSCHANGED"
    msgList(&H48) = "WM_POWER"
    msgList(&H49) = "WM_COPYGLOBALDATA"
    msgList(&H4A) = "WM_COPYDATA"
    msgList(&H4B) = "WM_CANCELJOURNAL"
    msgList(&H4E) = "WM_NOTIFY"
    msgList(&H50) = "WM_INPUTLANGCHANGEREQUEST"
    msgList(&H51) = "WM_INPUTLANGCHANGE"
    msgList(&H52) = "WM_TCARD"
    msgList(&H53) = "WM_HELP"
    msgList(&H54) = "WM_USERCHANGED"
    msgList(&H55) = "WM_NOTIFYFORMAT"
    msgList(&H7B) = "WM_CONTEXTMENU"
    msgList(&H7C) = "WM_STYLECHANGING"
    msgList(&H7D) = "WM_STYLECHANGED"
    msgList(&H7E) = "WM_DISPLAYCHANGE"
    msgList(&H7F) = "WM_GETICON"
    msgList(&H80) = "WM_SETICON"
    msgList(&H81) = "WM_NCCREATE"
    msgList(&H82) = "WM_NCDESTROY"
    msgList(&H83) = "WM_NCCALCSIZE"
    msgList(&H84) = "WM_NCHITTEST"
    msgList(&H85) = "WM_NCPAINT"
    msgList(&H86) = "WM_NCACTIVATE"
    msgList(&H87) = "WM_GETDLGCODE"
    msgList(&H88) = "WM_SYNCPAINT"
    msgList(&HA0) = "WM_NCMOUSEMOVE"
    msgList(&HA1) = "WM_NCLBUTTONDOWN"
    msgList(&HA2) = "WM_NCLBUTTONUP"
    msgList(&HA3) = "WM_NCLBUTTONDBLCLK"
    msgList(&HA4) = "WM_NCRBUTTONDOWN"
    msgList(&HA5) = "WM_NCRBUTTONUP"
    msgList(&HA6) = "WM_NCRBUTTONDBLCLK"
    msgList(&HA7) = "WM_NCMBUTTONDOWN"
    msgList(&HA8) = "WM_NCMBUTTONUP"
    msgList(&HA9) = "WM_NCMBUTTONDBLCLK"
    msgList(&HAB) = "WM_NCXBUTTONDOWN"
    msgList(&HAC) = "WM_NCXBUTTONUP"
    msgList(&HAD) = "WM_NCXBUTTONDBLCLK"
    msgList(&HE0) = "SBM_SETPOS"
    msgList(&HE1) = "SBM_GETPOS"
    msgList(&HE2) = "SBM_SETRANGE"
    msgList(&HE3) = "SBM_GETRANGE"
    msgList(&HE4) = "SBM_ENABLE_ARROWS"
    msgList(&HE6) = "SBM_SETRANGEREDRAW"
    msgList(&HE9) = "SBM_SETSCROLLINFO"
    msgList(&HEA) = "SBM_GETSCROLLINFO"
    msgList(&HEB) = "SBM_GETSCROLLBARINFO"
    msgList(&HFF) = "WM_INPUT"
    msgList(&H100) = "WM_KEYDOWN"
    msgList(&H101) = "WM_KEYUP"
    msgList(&H102) = "WM_CHAR"
    msgList(&H103) = "WM_DEADCHAR"
    msgList(&H104) = "WM_SYSKEYDOWN"
    msgList(&H105) = "WM_SYSKEYUP"
    msgList(&H106) = "WM_SYSCHAR"
    msgList(&H107) = "WM_SYSDEADCHAR"
    msgList(&H108) = "WM_KEYLAST"
    msgList(&H109) = "WM_WNT_CONVERTREQUESTEX"
    msgList(&H10A) = "WM_CONVERTREQUEST"
    msgList(&H10B) = "WM_CONVERTRESULT"
    msgList(&H10C) = "WM_INTERIM"
    msgList(&H10D) = "WM_IME_STARTCOMPOSITION"
    msgList(&H10E) = "WM_IME_ENDCOMPOSITION"
    msgList(&H10F) = "WM_IME_COMPOSITION"
    msgList(&H110) = "WM_INITDIALOG"
    msgList(&H111) = "WM_COMMAND"
    msgList(&H112) = "WM_SYSCOMMAND"
    msgList(&H113) = "WM_TIMER"
    msgList(&H114) = "WM_HSCROLL"
    msgList(&H115) = "WM_VSCROLL"
    msgList(&H116) = "WM_INITMENU"
    msgList(&H117) = "WM_INITMENUPOPUP"
    msgList(&H118) = "WM_SYSTIMER"
    msgList(&H11F) = "WM_MENUSELECT"
    msgList(&H120) = "WM_MENUCHAR"
    msgList(&H121) = "WM_ENTERIDLE"
    msgList(&H122) = "WM_MENURBUTTONUP"
    msgList(&H123) = "WM_MENUDRAG"
    msgList(&H124) = "WM_MENUGETOBJECT"
    msgList(&H125) = "WM_UNINITMENUPOPUP"
    msgList(&H126) = "WM_MENUCOMMAND"
    msgList(&H127) = "WM_CHANGEUISTATE"
    msgList(&H128) = "WM_UPDATEUISTATE"
    msgList(&H129) = "WM_QUERYUISTATE"
    msgList(&H132) = "WM_CTLCOLORMSGBOX"
    msgList(&H133) = "WM_CTLCOLOREDIT"
    msgList(&H134) = "WM_CTLCOLORLISTBOX"
    msgList(&H135) = "WM_CTLCOLORBTN"
    msgList(&H136) = "WM_CTLCOLORDLG"
    msgList(&H137) = "WM_CTLCOLORSCROLLBAR"
    msgList(&H138) = "WM_CTLCOLORSTATIC"
    msgList(&H200) = "WM_MOUSEMOVE"
    msgList(&H201) = "WM_LBUTTONDOWN"
    msgList(&H202) = "WM_LBUTTONUP"
    msgList(&H203) = "WM_LBUTTONDBLCLK"
    msgList(&H204) = "WM_RBUTTONDOWN"
    msgList(&H205) = "WM_RBUTTONUP"
    msgList(&H206) = "WM_RBUTTONDBLCLK"
    msgList(&H207) = "WM_MBUTTONDOWN"
    msgList(&H208) = "WM_MBUTTONUP"
    msgList(&H209) = "WM_MBUTTONDBLCLK"
    msgList(&H20A) = "WM_MOUSEWHEEL"
    msgList(&H20B) = "WM_XBUTTONDOWN"
    msgList(&H20C) = "WM_XBUTTONUP"
    msgList(&H20D) = "WM_XBUTTONDBLCLK"
    msgList(&H210) = "WM_PARENTNOTIFY"
    msgList(&H211) = "WM_ENTERMENULOOP"
    msgList(&H212) = "WM_EXITMENULOOP"
    msgList(&H213) = "WM_NEXTMENU"
    msgList(&H214) = "WM_SIZING"
    msgList(&H215) = "WM_CAPTURECHANGED"
    msgList(&H216) = "WM_MOVING"
    msgList(&H218) = "WM_POWERBROADCAST"
    msgList(&H219) = "WM_DEVICECHANGE"
    msgList(&H220) = "WM_MDICREATE"
    msgList(&H221) = "WM_MDIDESTROY"
    msgList(&H222) = "WM_MDIACTIVATE"
    msgList(&H223) = "WM_MDIRESTORE"
    msgList(&H224) = "WM_MDINEXT"
    msgList(&H225) = "WM_MDIMAXIMIZE"
    msgList(&H226) = "WM_MDITILE"
    msgList(&H227) = "WM_MDICASCADE"
    msgList(&H228) = "WM_MDIICONARRANGE"
    msgList(&H229) = "WM_MDIGETACTIVE"
    msgList(&H230) = "WM_MDISETMENU"
    msgList(&H231) = "WM_ENTERSIZEMOVE"
    msgList(&H232) = "WM_EXITSIZEMOVE"
    msgList(&H233) = "WM_DROPFILES"
    msgList(&H234) = "WM_MDIREFRESHMENU"
    msgList(&H280) = "WM_IME_REPORT"
    msgList(&H281) = "WM_IME_SETCONTEXT"
    msgList(&H282) = "WM_IME_NOTIFY"
    msgList(&H283) = "WM_IME_CONTROL"
    msgList(&H284) = "WM_IME_COMPOSITIONFULL"
    msgList(&H285) = "WM_IME_SELECT"
    msgList(&H286) = "WM_IME_CHAR"
    msgList(&H288) = "WM_IME_REQUEST"
    msgList(&H290) = "WM_IME_KEYDOWN"
    msgList(&H291) = "WM_IME_KEYUP"
    msgList(&H2A0) = "WM_NCMOUSEHOVER"
    msgList(&H2A1) = "WM_MOUSEHOVER"
    msgList(&H2A2) = "WM_NCMOUSELEAVE"
    msgList(&H2A3) = "WM_MOUSELEAVE"
    msgList(&H300) = "WM_CUT"
    msgList(&H301) = "WM_COPY"
    msgList(&H302) = "WM_PASTE"
    msgList(&H303) = "WM_CLEAR"
    msgList(&H304) = "WM_UNDO"
    msgList(&H305) = "WM_RENDERFORMAT"
    msgList(&H306) = "WM_RENDERALLFORMATS"
    msgList(&H307) = "WM_DESTROYCLIPBOARD"
    msgList(&H308) = "WM_DRAWCLIPBOARD"
    msgList(&H309) = "WM_PAINTCLIPBOARD"
    msgList(&H30A) = "WM_VSCROLLCLIPBOARD"
    msgList(&H30B) = "WM_SIZECLIPBOARD"
    msgList(&H30C) = "WM_ASKCBFORMATNAME"
    msgList(&H30D) = "WM_CHANGECBCHAIN"
    msgList(&H30E) = "WM_H8) = WM_NCACTIVATEWM_CTLCOLORSCROLLBARWM_CHANGECBCHAINHSCROLLCLIPBOARD"
    msgList(&H30F) = "WM_QUERYNEWPALETTE"
    msgList(&H310) = "WM_PALETTEISCHANGING"
    msgList(&H311) = "WM_PALETTECHANGED"
    msgList(&H312) = "WM_HOTKEY"
    msgList(&H317) = "WM_PRINT"
    msgList(&H318) = "WM_PRINTCLIENT"
    WM_MDICASCADEmsgList(&H319) = "WM_APPCOMMAND"
    msgList(&H358) = "WM_HANDHELDFIRST"
    msgList(&H35F) = "WM_HANDHELDLAST"
    msgList(&H360) = "WM_AFXFIRST"
    msgList(&H37F) = "WM_AFXLAST"
    msgList(&H380) = "WM_PENWINFIRST"
    msgList(&H381) = "WM_RCRESULT"
    msgList(&H382) = "WM_HOOKRCRESULT"
    msgList(&H383) = "WM_GLOBALRCCHANGE"
    msgList(&H384) = "WM_SKB"
    msgList(&H385) = "WM_PENCTL"
    msgList(&H386) = "WM_PENMISC"
    msgList(&H387) = "WM_CTLINIT"
    msgList(&H388) = "WM_PENEVENT"
    msgList(&H38F) = "WM_PENWINLAST"
End Sub

Форма:
Код: Выделить всё
' frmMain.frm - демонстрация работы многопоточности в NativeDLL на примере внедрения DLL и выполнению сабклассинга
' © Кривоус Анатолий Анатольевич (The trick), 2014

Option Explicit

Dim isDown      As Boolean      ' Флаг поиска
Dim curHwnd     As Long         ' Текущее сабклассируемое окно
Dim prevWnd     As Long         ' Предыдущее помеченное окно
Dim mIcon       As StdPicture   ' Иконка окна
Dim iconHeight  As Long         ' Высота состояния иконки
Dim msgList()   As String       ' Список сообщений

' // Обработчик сабклассируемого окна (указатели соответствуют адресам в АП сабклассируемого процесса)
Public Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, defCall As Long) As Long
    ' В зависимости от выбора вкладки:
    Select Case tabMain.SelectedItem.Index
    Case 1
        ' Ограничение на минимальный размер окна
        Select Case uMsg
        Case WM_GETMINMAXINFO
            Dim mmInf   As MINMAXINFO
            ' Получаем структуру MINMAXINFO из процесса, в котором нужное окно
            If ReadProcessMemory(hProcess, ByVal lParam, mmInf, Len(mmInf), 0) = 0 Then Exit Function
            ' Устанавливаем ограничения
            mmInf.ptMinTrackSize.x = sldWidth.Value
            mmInf.ptMinTrackSize.y = sldHeight.Value
            ' Записываем назад в АП нужного процесса
            WriteProcessMemory hProcess, ByVal lParam, mmInf, Len(mmInf), 0
            ' Вызов по умолчанию не нужен
            defCall = False
        End Select
    Case 2
        ' Клик в окне, просто меняем цвет фона вкладки и показываем лейбл
        Select Case uMsg
        Case WM_LBUTTONDOWN
            picContainer(1).BackColor = vbHighlight
            lblClick.Visible = True
        Case WM_LBUTTONUP
            picContainer(1).BackColor = vbButtonFace
            lblClick.Visible = False
        End Select
    Case 3
        ' Лог сообщений
        Dim sMsg As String
        ' Проверяем имя сообщения
        If uMsg > UBound(msgList) Then
            sMsg = "Unknown 0x" & Hex(uMsg)
        Else
            If Len(msgList(uMsg)) = 0 Then
                sMsg = "Unknown 0x" & Hex(uMsg)
            Else
                sMsg = msgList(uMsg)
            End If
        End If
        ' Добавляем в список вместе с параметрами
        With lvwMsg.ListItems.Add(, , sMsg)
            .SubItems(1) = wParam
            .SubItems(2) = lParam
            ' Чтобы видно было всегда было последнее сообщение
            .Selected = True
        End With
    End Select
End Function

' // Получить хендл окна в котором находится курсор
Private Function GetWindowFromCursor() As Long
    Dim pt As POINTAPI
    ' Получаем координаты курсора
    GetCursorPos pt
    ' Получаем хендл окна
    GetWindowFromCursor = WindowFromPoint(pt.x, pt.y)
End Function

' // Пометить окно рамкой
Private Sub MarkWindow(ByVal hwnd As Long)
    Dim hRgn    As Long
    Dim r2      As Long
    Dim dc      As Long
    Dim rc      As RECT
    ' Создаем регион для того, чтобы в него записать регион окна
    hRgn = CreateRectRgn(0, 0, 1, 1)
    ' Получаем контекст устройства окна
    dc = GetWindowDC(hwnd)
    ' Получаем регион окна
    If (GetWindowRgn(hwnd, hRgn) And (Not NULLREGION)) = 0 Then
        ' Если регион - нулевой или ошибка
        ' Получаем прямоугольник окна
        GetWindowRect hwnd, rc
        ' Удаляем предыдущий созданный регион
        DeleteObject hRgn
        ' Преобразуме координаты окна в свою СО
        OffsetRect rc, -rc.Left, -rc.Top
        ' Создаем ркгион по прямоугольнику окна
        hRgn = CreateRectRgn(rc.Left, rc.Top, rc.Right, rc.Bottom)
    End If
    ' Получаем режим наложения
    r2 = GetROP2(dc)
    ' Задаем XOR наложение, теперь рисуя белым цветом мы получаем инверсию цветов.
    ' Если еще раз нарисовать в том же месте, то фон восстановится на первоначальный
    SetROP2 dc, R2_XORPEN
    ' Рисуем рамку
    FrameRgn dc, hRgn, GetStockObject(WHITE_BRUSH), 3, 3
    ' Устанавливаем режим наложения, как был
    SetROP2 dc, r2
    ' Освободить контекст
    ReleaseDC hwnd, dc
    ' Удалить регион
    DeleteObject hRgn
End Sub

' // Загрузка
Private Sub Form_Load()
    ' Текущий путь - папка проекта
    ChDir App.Path: ChDrive App.Path
    ' Инициализация
    If Not Initialize() Then End
    ' Загрузка иконки
    Set mIcon = LoadResPicture(101, vbResBitmap)
    ' Высота иконки (3 состояния)
    iconHeight = ScaleY(mIcon.Height, vbHimetric, vbPixels) \ 3
    ' Рисуем иконку по умолчанию (Stopped)
    picIcon.PaintPicture mIcon, 0, 0, , iconHeight, , , , iconHeight
    ' Загружаем список сообщений
    SetWMList msgList()
    ' Статус
    Me.Caption = "Stopped"
    ' Обновление контролов
    sldWidth_Change
    sldHeight_Change
    tabMain_Click
End Sub

' // Завершение
Private Sub Form_Unload(Cancel As Integer)
    If curHwnd Then
        ' Если был сабклассинг - снимаем
        StopSubclass curHwnd
    End If
    ' Деинициализация
    Clear
End Sub

' // Изменение размера вкладки
Private Sub picContainer_Resize(Index As Integer)
    If Index = 2 Then
        ' В режиме отображения списка, растягиваем его на всю вкладку
        lvwMsg.Move 0, 0, picContainer(Index).ScaleWidth, picContainer(Index).ScaleHeight
    End If
End Sub

' // Клик по иконке окна
Private Sub picIcon_Click()
    ' Если был сабклассинг, то останавливаем
    If curHwnd Then
        StopSubclass curHwnd
        ' Сброс текущего окна
        curHwnd = 0
        ' Обновляем иконку
        picIcon.PaintPicture mIcon, 0, 0, , iconHeight, , , , iconHeight
        ' Обновляем статус
        Me.Caption = "Stopped"
    End If
End Sub

' // Нажатие кнопки мыши на иконке окна
Private Sub picIcon_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    ' Если нет сабклассинга то
    If curHwnd = 0 Then
        ' Начать поиск окон
        isDown = True
        ' Иконка указателя мыши - перекрестие
        picIcon.MousePointer = vbCrosshair
        ' Обновляем иконку
        picIcon.PaintPicture mIcon, 0, 0, , iconHeight, , iconHeight, , iconHeight
        ' Предыдущего маркированного окна пока еще не было
        prevWnd = 0
    End If
End Sub

' // Перемещение мыши при поиске окна
Private Sub picIcon_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    ' Если идет поиск окон
    If isDown Then
        Dim handle As Long
        ' Получаем окно под курсором
        handle = GetWindowFromCursor
        ' Если есть окно под курсором
        If handle Then
            ' Если оно соответствует предыдущему, то выходим
            If handle = prevWnd Then
                Exit Sub
            Else
                ' Иначе обновляем предыдущее окно (стираем рамку)
                MarkWindow prevWnd
                ' Рисуем рамку на новом окне
                MarkWindow handle
            End If
        End If
        ' Предыдущее окно - текущее
        prevWnd = handle
        ' Хендл окна в заголовок
        Me.Caption = Hex(handle)
    End If
End Sub

' // Отпускание мыши при поиске окон
Private Sub picIcon_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim handle As Long
    ' Поиск окон закончен
    isDown = False
    ' Если есть активный сабкласинг, то выходим (отключится в событии Click)
    If curHwnd Then Exit Sub
    ' Курсор мыши по умолчанию
    picIcon.MousePointer = vbDefault
    ' Получаем окно под курсором
    handle = GetWindowFromCursor
    ' Если есть такое окно и не было ошибок
    If handle Then
        ' Если хендл совпадает с предыдущим маркированным окном
        If handle = prevWnd Then
            ' Стираем рамку
            MarkWindow handle
        End If
        ' Включаем сабклассинг
        If Not StartSubclass(handle) Then
            Me.Caption = "Stopped"
            picIcon.PaintPicture mIcon, 0, 0, , iconHeight, , , , iconHeight: Exit Sub
        End If
        ' Текущее окно
        curHwnd = handle
        picIcon.PaintPicture mIcon, 0, 0, , iconHeight, , iconHeight * 2, , iconHeight
        Me.Caption = "Running " & Hex(curHwnd)
    Else
        picIcon.PaintPicture mIcon, 0, 0, , iconHeight, , , , iconHeight
        Me.Caption = "Stopped"
    End If
   
End Sub
Private Sub sldWidth_Change()
    lblWidth.Caption = "Width: " & sldWidth.Value
End Sub
Private Sub sldWidth_Scroll()
    sldWidth_Change
End Sub
Private Sub sldHeight_Change()
    lblHeight.Caption = "Height: " & sldHeight.Value
End Sub
Private Sub sldHeight_Scroll()
    sldHeight_Change
End Sub

Private Sub tabMain_Click()
    Static prevTab As Long
    picContainer(prevTab).Visible = False
    prevTab = tabMain.SelectedItem.Index - 1
    picContainer(prevTab).Move tabMain.ClientLeft, tabMain.ClientTop, tabMain.ClientWidth, tabMain.ClientHeight
    picContainer(prevTab).Visible = True
End Sub

Разберем подробно код. При загрузке формы вызываем функцию Initialize, которая инициализирует данные необходимые для сабклассинга. Во-первых создаем мьютекс для синхронизации, файл-маппинг для обмена данными и проецируем его представление, регистрируем сообщение WM_SENDMESSAGE, загружаем библиотеку с процедурой хука и сабклассим главное окно для приема сообщений. Далее при успехе загружаем иконку для состояний сабклассинга и загружаем список сообщений.
Для старта сабклассинга нужно зажать кнопку мыши на контроле picIcon и переместить ее на нужный контрол. При этом идет получение хендла окна под курсором и его маркировка рамкой. Для рамки берется либо регион окна, если он существует, в противном случае он создается на основе прямоугольника окна. Регион обрисовывается рамкой через R2_XOR наложение (vbXorPen), для снятия пометки просто еще раз рисуется рамка. При отпускании кнопки над окном, получаем его хендл и запускаем функцию StartSubclass. В этой процедуре мы проверяем поток (в своем потоке я запретил перехватывать сообщения т.к. может произойти рекурсия и вылет), при необходимости устанавливаем сабклассинг. Далее открываем процесс-"жертву", т.к. нам понадобится чтение и запись в его адресное пространство при обработке сообщений, передавая флаги PROCESS_VM_OPERATION, PROCESS_VM_WRITE, PROCESS_VM_READ. Теперь для того чтобы начать сабклассинг нужно подготовить данные для процесса-"жертвы", поэтому захватываем мьютекс и после этого ставим хук WH_GETMESSAGE в потоке процесса-"жертвы". После этого копируем данные в общую память, можем быть уверенными что поток-"жертва" не будет оттуда читать. Даже если процедура GetMsgProc начнет свое выполнение она будет ждать в функции WaitForSingleObject пока мы не освободим мьютекс. После копирования освобождаем мьютекс, теперь все готово.
После получения очередного сообщения окном-"жертвой" мы передаем его нашему приложению из процедуры WndProc находящейся в DLL, которая загружена в АП процесса-"жертвы". В нашем приложении мы при получении WM_SENDMESSAGE копируем данные из общей памяти и передаем их на обработку методу формы WndProc.
В этом методе, мы в зависимости от выбранной вкладки так или иначе обрабатываем сообщения. В первом случае мы ограничиваем минимальный рамер окна, посредством обработки сообщения WM_GETMINMAXINFO. Нужно помнить что адреса передаваемые в оконную процедуру - это адреса в АП процесса-"жертвы", для нашего процесса они недействительны. Из-за этого мы вместо CopyMemory используем ReadProcessMemory и WriteProcessMemory. Во-втором обрабатываем WM_LBUTTONDOWN и WM_LBUTTONUP и в своем процессе помечаем вкладку. В-третьем просто заносим название сообщения и параметры в список.
Для остановки сабклассинга нужно нажать на иконку, которая будет помечена как "STOP". Тем самым вызывается функция StopSubclass. В ней мы передаем окну-"жертве" сообщение WM_SENDMESSAGE, тем самым говоря что мы заканчиваем сабклассинг. В DLL, в функции WndProc, как я описал выше, мы производим деинициализацию. После деинициализации происходит возврат в наше приложение и снимается хук посредством вызова UnhookWindowsHookEx. После система выгружает нашу DLL из памяти процесса-"жертвы".
Изображение
Как мы увидели DLL, написанная на VB6, отлично работает в чужих программах и потоках. Данная DLL написана только для тестирования и демонстрации возможностей VB6. Я не ставил перед собой задачи написания законченной DLL для использования в проектах, поэтому DLL намеренно обладает ограничениями и имеет неправильную архитектуру (нельзя делать множественный сабклассинг и другие ограничения и баги), отсутствуют проверки. Для демонстрации возможностей этого достаточно.
___________________________________________________________________________________________
Как мы могли убедиться что многопоточность вполне работает в программах написанных на VB6, и DLL, написанные на VB6 работают в любых программах.
Всем спасибо за внимание, удачи.
Вложения
SubclassNativeDLL.rar
Исходники
(67.93 Кб) Скачиваний: 195
UA6527P

Вернуться в The trick

Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 3

    TopList