Hello everyone! This part is rather more about DLL injections than about threading as such, but because DLL can run programs with different numbers of threads I made this as a continuation of the theme of multi-threading in VB6. In the last article, I wrote about the possibility of creating a thread in the DLL, and the method of creating a native DLL for VB6. I also wrote that such a DLL will work in any application, but did not result in an example. In this section we will write a DLL that will be performed in another 32-bit process and execute our code there. As an example, make an application that will perform subclassing a window in another thread and send messages in our application that we can handle. Write once - DLL for example only and is not intended for use in applications as There are disadvantages to minimize code as I did not eliminate.
I decided to make use of 3 cases:
- Limiting the minimum size overlapping windows.
- Tracking button press/release the mouse in the window.
- Log messages.
So, first you need to come up with a interaction mechanism between processes. I decided to go the following way:
- For the exchange of data between applications will use FileMapping.
- To send a message from the proces- "victim" to our application, we will use a new recorded message.
- For notification of completion subclassing will transmit a message to the other side.
Now you need to consider how to implement the launch. Put the hook "WH_GETMESSAGE" on a thread that contains the window. Now our DLL is loaded into the address space of the process of the victim. In the callback function "GetMsgProc" the first call will initialize the data and set the desired window subclassing to exchange as mentioned above use the file-mapping. So the code:
Code:
clare 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