Эта часть скорее больше о внедрении DLL чем о многопоточности как таковой, но т.к. DLL может работать в программах с различным числом потоков то я сделал эту часть как продолжение темы о многопоточности в VB6. В прошлой части я написал о возможности создания потока в DLL, и о методе создания нативной DLL на VB6. Также я написал о том, что такая DLL будет работать в любом приложении, но примера не привел. В этой части мы напишем DLL которая будет выполняться в чужом 32-разрядном процессе и выполнять там наш код. В качестве примера сделаем приложение которое будет осуществлять сабклассинг окна в другом потоке и передавать в наше приложение сообщения, которые мы сможем обработать. Напишу сразу - DLL только для примера и не предназначена для работы в приложениях, т.к. имеются недостатки которые в качестве экономии кода я не устранял.
Я решил сделать 3 случая использования:
- Ограничение минимального размера перекрывающегося окна.
- Отслеживания нажатий/отпусканий кнопок мыши в окне.
- Лог сообщений.
- Для обмена данными между приложениями будем использовать проецированный в память файл.
- Для передачи сообщения от процесса-"жертвы" нашему приложению, будем использовать новое зарегистрированное сообщение.
- Для уведомления о завершении сабклассинга передавать сообщение будем в другую сторону.
- Код: Выделить всё
' 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 работают в любых программах.
Всем спасибо за внимание, удачи.
