' 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

' 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"

  TrickSubclassMutex  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