На главную Наши проекты:
Журнал   ·   Discuz!ML   ·   Wiki   ·   DRKB   ·   Помощь проекту
ПРАВИЛА FAQ Помощь Поиск Участники Календарь Избранное RSS
Дорогие друзья! Поздравляем вас с днём Победы!
msm.ru
! Правила раздела Visual Basic: Общие вопросы
Здесь обсуждаются вопросы по языку Visual Basic 1-6 (а так же по схожим языкам, как, например, PowerBASIC).
Вопросы по Visual Basic .NET (это который входит в состав Visual Studio 2002/2003/2005/2008+, для тех, кто не в курсе) обсуждаются в разделе .NET.

Обратите внимание:
1. Прежде чем начать новую тему или отправить сообщение, убедитесь, что Вы не нарушаете правил форума!
2. Обязательно воспользуйтесь поиском. Возможно, Ваш вопрос уже обсуждали. Полезные ссылки приведены ниже.
3. Темы с просьбой выполнить какую-либо работу за автора в этом разделе не обсуждаются. Студенты, вам сюда: ПОМОЩЬ СТУДЕНТАМ!
4. Используйте теги [ code=vba ] ...текст программы... [ /code ] для выделения текста программы подсветкой.
5. Помните, здесь телепатов нет. Формулируйте свой вопрос максимально грамотно и чётко: Как правильно задавать вопросы
6. Запрещено отвечать в темы месячной (и более) давности, без веских на то причин.

Полезные ссылки:
user posted image FAQ Сайта user posted image FAQ Раздела user posted image Кладовка user posted image Наши Исходники user posted image API-Guide user posted image Поиск по Разделу user posted image MSDN Library Online user posted image Google
Ваше мнение о модераторах: user posted image SCINER, user posted image B.V.
Модераторы: SCINER, B.V.
Ссылки по теме:
  
> Многопоточность в VB6 часть 3 , Внедрение в чужой процесс.
TheTrik
Сообщ. #1 ,
    Full Member
    ***
    Профиль · PM
    Поощрения: 10 Dgm
    Рейтинг (т): 29
    Эта часть скорее больше о внедрении DLL чем о многопоточности как таковой, но т.к. DLL может работать в программах с различным числом потоков то я сделал эту часть как продолжение темы о многопоточности в VB6. В прошлой части я написал о возможности создания потока в DLL, и о методе создания нативной DLL на VB6. Также я написал о том, что такая DLL будет работать в любом приложении, но примера не привел. В этой части мы напишем DLL которая будет выполняться в чужом 32-разрядном процессе и выполнять там наш код. В качестве примера сделаем приложение которое будет осуществлять сабклассинг окна в другом потоке и передавать в наше приложение сообщения, которые мы сможем обработать. Напишу сразу - DLL только для примера и не предназначена для работы в приложениях, т.к. имеются недостатки которые в качестве экономии кода я не устранял.
    Я решил сделать 3 случая использования:
    • Ограничение минимального размера перекрывающегося окна.
    • Отслеживания нажатий/отпусканий кнопок мыши в окне.
    • Лог сообщений.
    Итак, сначала нужно придумать механизм взаимодействия между процессами. Я решил пойти следующим путем:
    1. Для обмена данными между приложениями будем использовать проецированный в память файл.
    2. Для передачи сообщения от процесса-"жертвы" нашему приложению, будем использовать новое зарегистрированное сообщение.
    3. Для уведомления о завершении сабклассинга передавать сообщение будем в другую сторону.
    Теперь нужно продумать как осуществлять запуск. Ставим хук WH_GETMESSAGE на поток в котором содержится окно. Теперь наша DLL загрузится в АП процесса жертвы. В callback функции GetMsgProc при первом вызове будем инициализировать данные и устанавливать сабклассинг на нужное окно, для обмена как было сказано выше используем файл-маппинг. Итак код:
    ExpandedWrap disabled
      ' 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. Для начала разберем структуру файл-маппинга:
    user posted image

    Проверяем сообщение, если это наше зарегистрированное, то его может отправить только наше приложение при снятии сабклассинга, поэтому выполняем деинициализацию. Иначе формируем данные сообщения и, захватив мьютекс, пишем их в файл маппинг со смещения 0x0Ch (1210) и передаем их в главное окно нашего приложения для обработки. Т.к. мы используем SendMessage для передачи, выход из нее не произойдет пока мы в своем приложении не завершим обработку этого сообщения. При возврате проверяем флаг defCall, который отвечает пускать ли сообщение дальше в старую оконную процедуру или нет.
    Теперь разберем главное приложение:
    Модуль:
    ExpandedWrap disabled
      ' 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

    Форма:
    ExpandedWrap disabled
      ' 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 из памяти процесса-"жертвы".
    user posted image

    Как мы увидели DLL, написанная на VB6, отлично работает в чужих программах и потоках. Данная DLL написана только для тестирования и демонстрации возможностей VB6. Я не ставил перед собой задачи написания законченной DLL для использования в проектах, поэтому DLL намеренно обладает ограничениями и имеет неправильную архитектуру (нельзя делать множественный сабклассинг и другие ограничения и баги), отсутствуют проверки. Для демонстрации возможностей этого достаточно. Демонстрация.

    Как мы могли убедиться что многопоточность вполне работает в программах написанных на VB6, и DLL, написанные на VB6 работают в любых программах.
    Всем спасибо за внимание, удачи.
    Прикреплённый файлПрикреплённый файлSubclassNativeDLL.rar (67,93 Кбайт, скачиваний: 177)
    0 пользователей читают эту тему (0 гостей и 0 скрытых пользователей)
    0 пользователей:


    Рейтинг@Mail.ru
    [ Script execution time: 0,0456 ]   [ 18 queries used ]   [ Generated: 10.05.24, 12:12 GMT ]  
    Powered by Invision Power Board(U) v1.2 © 2003  IPS, Inc.