Часть 1. Многопоточность в ActiveX DLL. Многие интересуются вопросами многопоточности программ, написанных на VB6. Писать многопоточные программы на VB6 вполне реально, у меня есть множество примеров которые я также публиковал в своем блоге, но существуют ограничения, которые так или иначе можно обойти. Этот вопрос я рассматривать в данном посте не буду, а рассмотрю более правильный (с точки зрения программирования на VB6) метод многопоточности с использованием объектов. В данном методе нет никаких ограничений, в отличии от многопоточности в Standart EXE, а также есть все плюсы ООП. Также хочу сразу заметить что IDE не предназначена для отладки многопоточных программ, поэтому отлаживать такие программы в IDE не получится. Для отладки я использую другой отладчик. Также можно отдельно отлаживать потоки, а потом уже собирать EXE. Используя несколько потоков, у нас появляется возможность вызывать методы асинхронно, с сохранением синхронности; т.е. мы сможем вызывать методы как и в отдельном потоке, так и в своем. Например методы требующие большой вычислительной загрузки стоит вызывать асинхронно и получать, при окончании, уведомление в виде события. Такие методы (свойства) которые работают быстро, можно вызывать синхронно. Одна из проблем создания потока на VB6 в Standart EXE, является невозможность использования вызовов WinAPI функций через Declare. В отличии от функций задекларированных в библиотеки типов и попадающих в импорт, Declared-функции после каждого вызова устанавливают свойство объектной переменной Err.LastDllError. Делается это посредством вызова функции __vbaSetSystemError из MSVBVM. Объект Err, является потокозависимым, а ссылка на него находится в локальном хранилище потока (TLS). Для каждого потока должен создаваться свой объект Err, иначе при вызове функции __vbaSetSystemError, рантайм запросит ссылку из хранилища, а у нас ее там нет (точнее там 0) и произойдет чтение по неправильному адресу, как следствие вылет. Чтобы предотвратить такое поведение, можно декларировать функции в tlb, тогда не будет вызываться функция __vbaSetSystemError. Также можно инициализировать Err объект, например создать объект из DLL в новом потоке, тогда рантайм инициализирует этот объект сам. Но для создания нового объекта, нужно сначала инициализировать поток для работы с COM, для этого нужно вызвать CoInitialize(Ex), но мы не можем вызывать функции. Можно ее задекларировать в tlb (только ее одну), тогда все честно; также можно ее вызвать из ассемблерного переходника к примеру или любым другим способом. Я всегда иду по другому. Зачем мне LastDllError? Я могу просто напросто сам вызвать GetLastError когда мне надо. Поэтому я просто нахожу адрес функции __vbaSetSystemError и пишу первой инструкцией выход из процедуры (ret). Это конечно не так красиво, но зато надежно и быстро. Можно сделать так только для одной функции CoInitialize, а потом восстановить __vbaSetSystemError. Теперь мы можем вызывать Declared функции в новом потоке, что дает нам безграничные возможности. После создания объекта (CreateObject), мы можем вызывать его методы, свойства, получать от него события и т.д., но просто так ссылку между потоками нельзя передавать, т.к. могут возникнуть ошибки из-за одновременного доступа к данным и т.п. Для передачи ссылки между потоками существует маршалинг. Мы будем использовать универсальный маршаллер, т.к. у нас ActiveX DLL имеет в себе библиотеку типов. Принцип работы я подробно расписывать не буду, для этого есть в сети много статей. Общий смысл в том, что вместо прямого вызова метода объекта, используется RPC запрос в другой компьютер/процесс/поток. Для обработки запросов нужно использовать цикл обработки сообщений, и раз так вышло, то и связь между потоками сделаем через сообщения. Для теста я написал простейшую ActiveX DLL с помощью которой можно скачать файл из сети, которая имеет несколько методов и генерирует события. Код (Visual Basic): ' Класс MultithreadDownloader - класс загрузчика ' © Кривоус Анатолий Анатольевич (The trick), 2014 Option Explicit Public Enum ErrorCodes OK NOT_INITIALIZE ERROR_CREATING_DST_FILE End Enum Private Declare Function InternetCloseHandle Lib "wininet" (ByRef hInternet As Long) As Boolean Private Declare Function InternetOpen Lib "wininet" Alias "InternetOpenW" (ByVal lpszAgent As Long, ByVal dwAccessType As Long, ByVal lpszProxy As Long, ByVal lpszProxyBypass As Long, ByVal dwFlags As Long) As Long Private Declare Function InternetOpenUrl Lib "wininet" Alias "InternetOpenUrlW" (ByVal hInternet As Long, ByVal lpszUrl As Long, ByVal lpszHeaders As Long, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByRef dwContext As Long) As Long Private Declare Function InternetReadFile Lib "wininet" (ByVal hFile As Long, lpBuffer As Any, ByVal dwNumberOfBytesToRead As Long, ByRef lpdwNumberOfBytesRead As Long) As Integer Private Declare Function HttpQueryInfo Lib "wininet" Alias "HttpQueryInfoW" (ByVal hRequest As Long, ByVal dwInfoLevel As Long, lpBuffer As Any, ByRef lpdwBufferLength As Long, ByRef lpdwIndex As Long) As Long Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileW" (ByVal lpFileName As Long, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Const INTERNET_OPEN_TYPE_PRECONFIG As Long = 0 Private Const INTERNET_FLAG_RELOAD As Long = &H80000000 Private Const HTTP_QUERY_CONTENT_LENGTH As Long = 5 Private Const HTTP_QUERY_FLAG_NUMBER As Long = &H20000000 Private Const CREATE_ALWAYS As Long = 2 Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80 Private Const INVALID_HANDLE_VALUE As Long = -1 Private Const GENERIC_WRITE As Long = &H40000000 Public Event Complete() Public Event Error(ByVal Code As Long) Public Event Progress(ByVal Size As Currency, ByVal TotalSize As Currency, cancel As Boolean) Private mBufferSize As Long Private mError As ErrorCodes Dim hInternet As Long Public Property Get ErrorCode() As ErrorCodes ErrorCode = mError End Property Public Property Get BufferSize() As Long BufferSize = mBufferSize End Property Public Property Let BufferSize(ByVal Value As Long) If Value > &H1000000 Or Value < &H400 Then Err.Raise vbObjectError, "MultithreadDownloader", "Wrong buffer size": Exit Property mBufferSize = Value End Property Public Sub Download(URL As String, Filename As String) Dim hFile As Long Dim hDst As Long Dim fSize As Currency Dim total As Long Dim prgSize As Currency Dim cancel As Boolean Dim buf() As Byte If hInternet = 0 Then mError = NOT_INITIALIZE: RaiseEvent Error(mError): Exit Sub hFile = InternetOpenUrl(hInternet, StrPtr(URL), 0, 0, INTERNET_FLAG_RELOAD, 0) If hFile = 0 Then mError = Err.LastDllError: RaiseEvent Error(mError): Exit Sub If HttpQueryInfo(hFile, HTTP_QUERY_CONTENT_LENGTH Or HTTP_QUERY_FLAG_NUMBER, fSize, 8, 0) Then hDst = CreateFile(StrPtr(Filename), GENERIC_WRITE, 0, ByVal 0&, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0) If hDst = INVALID_HANDLE_VALUE Then mError = ERROR_CREATING_DST_FILE: RaiseEvent Error(mError): Exit Sub ReDim buf(mBufferSize - 1) Do If InternetReadFile(hFile, buf(0), mBufferSize, total) = 0 Then mError = Err.LastDllError RaiseEvent Error(mError) InternetCloseHandle hFile Exit Sub End If WriteFile hDst, buf(0), total, 0, ByVal 0& prgSize = prgSize + CCur(total) / 10000@ RaiseEvent Progress(prgSize, fSize, cancel) Loop While (total = mBufferSize) And Not cancel CloseHandle hDst RaiseEvent Complete Else mError = Err.LastDllError RaiseEvent Error(mError) End If InternetCloseHandle hFile mError = OK End Sub Private Sub Class_Initialize() ' Инициализация WinInet hInternet = InternetOpen(StrPtr(App.ProductName), INTERNET_OPEN_TYPE_PRECONFIG, 0, 0, 0) mBufferSize = &H10000 End Sub Private Sub Class_Terminate() ' Деинициализация If hInternet Then InternetCloseHandle hInternet End Sub Код в принципе простой, если прочитать описание API функций. При вызове метода Download, начинает выполнятся загрузка, периодически (зависит от размера буфера) генерируется событие Progress. При ошибке генерируется событие Error, и при окончании Complete. BufferSize - задает размер буфера, при заполнении которого генерируется событие. Код демонстрационный и содержит недочеты.
Класс я назвал MultithreadDownloader, а библиотеку MTDownloader, соответственно ProgID этого объекта MTDownloader.MultithreadDownloader. После компиляции получаем описание интерфейсов через OleView, PEExplorer и т.п. В моем примере CLSID = {20FAEF52-0D1D-444B-BBAE-21240219905B}, IID = {DF3BDB52-3380-4B78-B691-4138300DD304}. Также я поставил галочку RemoteServerFiles чтобы получить на выходе библиотеку типов для нашей DLL, и будем подключать ее вместо DLL для гарантированного запуска приложения. Код клиентского приложения: Форма - Код (Visual Basic): ' frmDownloader.frm - форма загрузчика ' © Кривоус Анатолий Анатольевич (The trick), 2014 Option Explicit ' Объявляем объектную переменную с подпиской на события Dim WithEvents Downloader As MTDownloader.MultithreadDownloader Dim param As ThreadData ' Данные потока Dim tid As Long ' ИД потока Dim hThread As Long ' Описатель потока Dim mCancel As Boolean ' Если отмена закачки Dim mActive As Boolean ' Если активна закачка ' // Отмена Private Sub cmdCancel_Click() mCancel = True End Sub ' // Скачать файл Private Sub cmdDownload_Click() Dim ptr As Long ' Проверяем, идет ли уже вызов If WaitForSingleObject(param.hEvent, 0) = WAIT_OBJECT_0 Then ' Упаковываем параметры ptr = MT_DOWNLOAD_packParam(txtURL.Text, txtPath.Text) If ptr Then mCancel = False mActive = True ' Очистка прогрессбара picProgress.Cls ' Отправляем запрос на асинхронный вызов метода в другом потоке PostThreadMessage tid, WM_MT_DOWNLOAD, 0, ptr Else MsgBox "Не удалось упаковать параметры", vbCritical End If Else MsgBox "Скачивание еще идет", vbInformation End If End Sub ' // Окончание загрузки Private Sub Downloader_Complete() mActive = False MsgBox "Загрузка завершена" End Sub ' // Ошибка загрузки Private Sub Downloader_Error(ByVal Code As Long) mActive = False MsgBox "Ошибка" End Sub ' // Прогресс Private Sub Downloader_Progress(ByVal Size As Currency, ByVal TotalSize As Currency, cancel As Boolean) Dim sVal As String Dim wTxt As Single cancel = mCancel picProgress.Cls picProgress.Line (0, 0)-(Size / TotalSize, 1), vbRed, BF sVal = Format(Size / TotalSize, "##0%") wTxt = picProgress.TextWidth(sVal) picProgress.CurrentX = (1 - wTxt) / 2 picProgress.CurrentY = 0 picProgress.Print sVal picProgress.Refresh End Sub Private Sub Form_Initialize() InitCommonControlsEx 3435973.8623@ End Sub Private Sub Form_Load() Dim iid As UUID Dim obj As MTDownloader.MultithreadDownloader ' Удаляем вылет Declared функций RemoveLastDllError ' Создаем синхронизирующий объект param.hEvent = CreateEvent(ByVal 0&, 1, 0, 0) ' Создаем поток hThread = CreateThread(ByVal 0&, 0, AddressOf ThreadProc, ByVal VarPtr(param), 0, tid) If hThread = 0 Then MsgBox "Не удалось создать поток", vbCritical End End If ' Ждем инициализацию объекта WaitForSingleObject param.hEvent, INFINITE ' Если успешно If param.IStream Then ' Преобразуем интерфейс в бинарную форму IIDFromString StrPtr(IID_MultithreadDownloader), iid ' Получаем отмаршаленный указатель на объект CoGetInterfaceAndReleaseStream param.IStream, iid, obj Set Downloader = obj Else MsgBox "Не удалось создать объект", vbCritical End End If ' Проверяем корректность инициализации объекта If Downloader.ErrorCode = NOT_INITIALIZE Then MsgBox "Объект не инициализирован", vbCritical End End If ' Задаем размер буфера в 100 кб Downloader.BufferSize = &H10000 End Sub Private Sub Form_Unload(cancel As Integer) If mActive Then MsgBox "Идет загрузка" cancel = True Exit Sub End If If tid Then ' Освобождаем объект Set Downloader = Nothing ' Отправляем запрос на завершение потока PostThreadMessage tid, WM_QUIT, 0, 0 ' Ждем завершение, т.к. поток ссылается на param WaitForSingleObject hThread, INFINITE ' Закрываем описатели CloseHandle hThread CloseHandle param.hEvent End If End Sub
Модуль: Код (Visual Basic): ' modMain.bas - главный модуль загрузчика ' © Кривоус Анатолий Анатольевич (The trick), 2014 Option Explicit Public Type POINTAPI x As Long y As Long End Type Public Type msg hwnd As Long message As Long wParam As Long lParam As Long time As Long pt As POINTAPI End Type Public Type UUID Data1 As Long Data2 As Integer Data3 As Integer Data4(0 To 7) As Byte End Type Public Declare Function GetMessage Lib "user32" Alias "GetMessageW" (lpMsg As msg, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long Public Declare Function TranslateMessage Lib "user32" (lpMsg As msg) As Long Public Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageW" (lpMsg As msg) As Long Public Declare Function PostThreadMessage Lib "user32" Alias "PostThreadMessageW" (ByVal idThread As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Public Declare Function GetMem1 Lib "msvbvm60" (Src As Any, Dst As Any) As Long Public Declare Function GetMem4 Lib "msvbvm60" (Src As Any, Dst As Any) As Long Public Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long Public Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As Long) As Long Public Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long Public Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long Public Declare Function CoInitialize Lib "ole32" (pvReserved As Any) As Long Public Declare Function CoUninitialize Lib "ole32" () As Long Public Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Long, pclsid As UUID) As Long Public Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, lpiid As UUID) As Long Public Declare Function CoCreateInstance Lib "ole32" (rclsid As UUID, ByVal pUnkOuter As Long, ByVal dwClsContext As Long, riid As UUID, ppv As Any) As Long Public Declare Function CoMarshalInterThreadInterfaceInStream Lib "ole32.dll" (riid As UUID, ByVal pUnk As IUnknown, ppStm As Long) As Long Public Declare Function CoGetInterfaceAndReleaseStream Lib "ole32.dll" (ByVal pStm As Long, riid As UUID, pUnk As Any) As Long Public Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long Public Declare Function SetEvent Lib "kernel32" (ByVal hEvent As Long) As Long Public Declare Function ResetEvent Lib "kernel32" (ByVal hEvent As Long) As Long Public Declare Function CreateEvent Lib "kernel32" Alias "CreateEventW" (lpEventAttributes As Any, ByVal bManualReset As Long, ByVal bInitialState As Long, ByVal lpName As Long) As Long Public Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyW" (lpString1 As Any, lpString2 As Any) As Long Public Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (lpString As Any) As Long Public Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long Public Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long Public Declare Function GetProcessHeap Lib "kernel32" () As Long Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Public Declare Function InitCommonControlsEx Lib "comctl32" (icc As Any) As Long Public Const CLSCTX_INPROC_SERVER As Long = 1 Public Const PAGE_EXECUTE_READWRITE As Long = &H40& Public Const CLSID_MultithreadDownloader As String = "{20FAEF52-0D1D-444B-BBAE-21240219905B}" Public Const IID_MultithreadDownloader As String = "{DF3BDB52-3380-4B78-B691-4138300DD304}" Public Const WM_APP As Long = &H8000& Public Const WM_QUIT As Long = &H12 Public Const WM_MT_DOWNLOAD As Long = WM_APP ' Сообщение потоку чтобы вызвать метод Public Const INFINITE As Long = -1& Public Const WAIT_OBJECT_0 As Long = 0 Public Type ThreadData hEvent As Long ' Объект синхронизации IStream As Long ' Объект потока, получающий ссылку на отмаршалленый объект MultithreadDownloader End Type ' // Удаляем вылеты Declare функций, жертвуя Err.LastDllError ' // Если использовать tlb, то не нужна. Public Sub RemoveLastDllError() Dim hMod As Long Dim lpProc As Long ' Получаем адрес функции __vbaSetSystemError hMod = GetModuleHandle(StrPtr("msvbvm60")) lpProc = GetProcAddress(hMod, "__vbaSetSystemError") ' Делаем ret VirtualProtect lpProc, 1, PAGE_EXECUTE_READWRITE, 0 GetMem1 &HC3, ByVal lpProc End Sub ' // Функция потока Public Function ThreadProc(value As ThreadData) As Long Dim clsid As UUID Dim iid As UUID Dim obj As MTDownloader.MultithreadDownloader ' Инициализируем COM CoInitialize ByVal 0& ' Инициализируем CLSID и IID для создания и управления объектом IIDFromString StrPtr(IID_MultithreadDownloader), iid CLSIDFromString StrPtr(CLSID_MultithreadDownloader), clsid ' Создаем объект MTDownloader.MultithreadDownloader If CoCreateInstance(clsid, 0, CLSCTX_INPROC_SERVER, iid, obj) = 0 Then ' Маршаллинг для отлова событий в другом потоке CoMarshalInterThreadInterfaceInStream iid, obj, value.IStream ' Объект инициализирован SetEvent value.hEvent Else ' Объект не инициализирован SetEvent value.hEvent ' Деинициализация CoUninitialize ' Выход Exit Function End If Dim msg As msg Dim ret As Long Dim URL As String Dim fle As String ' Цикл обработки сообщений в новом потоке Do ret = GetMessage(msg, 0, 0, 0) If ret = -1 Or ret = 0 Then Exit Do ' Проверяем сообщения Select Case msg.message Case WM_MT_DOWNLOAD ' Получаем запакованные параметры, они лежат последовательно ret = lstrlen(ByVal msg.lParam) URL = Space(ret) lstrcpy ByVal StrPtr(URL), ByVal msg.lParam ret = lstrlen(ByVal msg.lParam + (ret + 1) * 2) fle = Space(ret) lstrcpy ByVal StrPtr(fle), ByVal msg.lParam + LenB(URL) + 2 ' Сбрасываем событие, чтобы нельзя было вызвать метод еще раз пока не отработает предыдущий вызов ResetEvent value.hEvent ' Вызываем метод obj.Download URL, fle ' Устанавливаем событие - объект свободен SetEvent value.hEvent ' Очищаем параметры HeapFree GetProcessHeap(), 0, ByVal msg.lParam Case Else TranslateMessage msg DispatchMessage msg End Select Loop ' Удаляем объекты Set obj = Nothing ' Деинициализация CoUninitialize End Function ' // Упаковка параметров последовательно Public Function MT_DOWNLOAD_packParam(URL As String, fileName As String) As Long MT_DOWNLOAD_packParam = HeapAlloc(GetProcessHeap(), 0, LenB(URL) + LenB(fileName) + 4) If MT_DOWNLOAD_packParam Then lstrcpy ByVal MT_DOWNLOAD_packParam, ByVal StrPtr(URL) lstrcpy ByVal MT_DOWNLOAD_packParam + LenB(URL) + 2, ByVal StrPtr(fileName) End If End Function Разберем подробно код. При загрузке формы (Form_Load), мы пропатчиваем рантайм для исключения ошибки использования Declared функций в неинициализированном потоке (RemoveLastDllError). Принцип я описал выше. Если мы создаем объект в другом потоке, то нам нужно как-то проверить в основном потоке, создался ли объект. Для этого я использовал простейший синхронизирующий объект - событие с ручным сбросом. Иницииализируем его в сброшенном состоянии. Далее создаем поток в функции ThreadProc, в качестве параметра передаем структуру из синхронизирующего события и ссылки на объект потока (Stream), который нужен для маршалинга. В этом объекте веренется ссылка на отмаршаленый указатель на объект. При успехе ждем срабатывания события (WaitForSingleObject). На этом основной поток приостанавливает свое выполнение пока мы не установим событие hEvent. В новом потоке сначала инициализируем COM (CoInitialize), переводим CLSID и IID в двоичную форму, создаем объект (CoCreateInstance). Здесь, если не нужна обработка ошибок, то можно использовать Код (Visual Basic): CreateObject("MTDownloader.MultithreadDownloader") В данном коде для создания объекта я использовал CoCreateInstance, т.к. до создания первого объекта мы не можем включить обработку ошибок (причина описана выше), после создания первого объекта далее можно создавать через VB-шный CreateObject. Если обработка ошибок не нужна, то можно сразу использовать CreateObject.
При успехе выполняем маршалинг, для этого вызываем функцию CoMarshalInterThreadInterfaceInStream, которая записывает в Stream (поток) информацию для создания прокси-объекта в другом потоке. Устанавливаем событие, этим самым говорим основному потоку что инициализация прошла. При неудаче также выставляем событие и деинициализируем COM в данном потоке, выходим (поток завершен). Признаком успешной инициализации становится ссылка IStream. Далее в этом потоке переходим к стандартному циклу обработки сообщений. Т.к. мы установили событие, основной поток просыпается и мы проверяем, успешно ли прошла инициализация. Если в IStream записана ссылка, значит все хорошо, иначе ошибка. Далее получаем указатель на прокси объект из потока вызовом CoGetInterfaceAndReleaseStream, тем самым также освобождаем объект Stream. Присваиваем нашей объектной переменной, подписанной на события, указатель на прокси-объект. Всеми этими манипуляциями теперь мы можем обращаться к объекту в другом потоке и получать от него события. Проверяем корректно ли инициализировался сам объект (hInternet<>0), и устанавливаем размер буфера в 64 кб, информация будет обновляться при очередной порции закаченных данных в 64 кБ. На этом инициализация закончена. Для того, чтобы нельзя было выполнить несколько запросов на закачку, мы будем синхронизировать запросы по созданному событию. Иначе просто если несколько раз щелкнуть на кнопке Download, то данные будут закачиваться последовательно, если ошибочно нажать 2 раза, то файл скачается 2 раза и перезапишется, ошибок не будет. При нажатии мы проверяем статус события, если оно установлено то закачки в данной момент нет. Для передачи данных в другой поток, выполним транспортировку (маршалинг) параметров в другой поток (MT_DOWNLOAD_packParam). Для этого выделим память в куче и скопируем данные (в нашем случае URL и FileName) в нее, а ссылку передадим в созданный поток. Сохранять я решил самым простым способом - 2 unicode-строки последовательно с завершающими нуль-терминалами. Передаем ссылку на параметры в очередь потока через PostThreadMessage, в качестве номера сообщения используем первый незанятый идентификатор WM_APP, который я назвал WM_MT_DOWNLOAD. В другом потоке в цикле, при получении сообщения WM_MT_DOWNLOAD, вытаскиваем параметры из кучи и вызываем метод Download, предварительно сбросив событие hEvent. Все. Пока выполняется метод мы не сможем вызвать его опять, а благодаря маршалингу мы получаем уведомления от объекта в виде событий в основном потоке. Обработчики событий элементарные и в пояснениях не нуждаются. Единственное что хочу добавить, что для размера файла я выбрал Currency, т.к. 64-битных целых чисел нет, а Currency это почти тоже самое, только деленное на 1000010. Помимо асинхронных вызовов у нас также остается возможность синхронного вызова, т.е. в коде формы вполне законно можем написать Downloader.Download URL, FileName. Можно сравнить преимущества и недостатки асинхронноги и синхронного вызовов. Пример не требует регистрации ActiveX DLL, достаточно положить ее в ту же папку благодаря манифесту. В итоге имеем многопоточное приложение которое работает на любой машине без запроса админских прав.
Часть 2 - создание Native DLL и вызов экспортируемой функции в другом потоке. Теперь я расскажу о еще одном методе написания многопоточных программ на VB6, а именно создание потока в Native DLL. В принципе здесь нет ничего сложного, передаем в CreateThread адрес экспортируемой функции и она будет исполнена в другом потоке. Все бы хорошо, но стандартными, документированными возможностями VB6 не позволяет создавать нативные DLL. Но не все так плохо, есть несколько приемов, с помощью которых можно создать нативную DLL, начиная от подмены линкера и заканчивая недокументированными секциями в vbp-файле. Как раз последний способ мы и будем использовать для создания DLL. Для начала нужно решить, что нам вообще нужно от DLL, чтобы можно было применить многопоточность. В прошлый раз я делал загрузку файла, сейчас я решил уделить внимание вычислениям. Т.е. в новом потоке у нас будут производится вычисления, а основной поток будет обслуживать GUI. Для теста я разработал DLL для работы с графикой, а если быть точнее то в DLL будут функции, которые преобразуют растровое изображение - накладывают различные эффекты. Как-то давно, когда я начинал программировать, и изучал фильтры на основе свертки, то мне очень не нравилась "тормознутость" этих методов. Теперь есть возможность засунуть вычисления в другой поток без блокировки главного. Я создал 10 функций, которые будут экспортироваться: Brightness - Яркость Contrast - Контрастность Saturation - Насыщенность GaussianBlur - Размытие EdgeDetect - Выделение контуров Sharpen - Резкость Emboss - Тиснение Minimum - Минимум Maximum - Максимум FishEye - "Рыбий глаз" Все функции имеют один и тот же прототип для того чтобы можно было вызывать из в отдельно потоке, принимают структуру ThreadData в качестве аргумента. Опишу поля подробней: pix() - двухмерный массив пикселов типа Byte, первая размерность задает RGBQUAD поля по горизонтали, вторая по вертикали. Т.е. pix(0,0) содержит синюю компоненту 0x0 пиксела, pix(1,0) - зеленую комопненту 0x0 пиксела, pix(2,0) - красную компоненту, pix(4,0) - синюю компоненту 1x0 пиксела и т.д. Как видно на вход подается массив пикселов в формате 32 бит на пиксел. Отсюда следует что первая размерность будет в 4 раза больше чем ширина картинки, а вторая - соответствовать высоте. value - величина эффекта. Например для GaussianBlur этот параметр отвечает за силу размытия, а в "Рыбьем глазе" за величину искажения. Для каждого эффекта свои диапазоны изменения value. percent - это ответный параметр. В нем содержится значение, характеризующее процент выполнения функции и из него мы в основном потоке будем обновлять прогрессбар. Диапазон от 0 до 1. Также помимо основных экспортируемых функций, у нас содержится еще вспомогательная неэкспортируемая функция Convolution, которая вычисляет свертку. На основании свертки в моей реализации работают эффекты тиснения, выделения краев и резкости. На этом описание модуля закончено, теперь перейдем непосредственно к созданию DLL. Итак, как я уже сказал мы будем создавать DLL с помощью недокументированных ключей компиляции. С этим понятно, теперь предстоит сделать выбор - какой тип проекта выбрать. Забегая вперед скажу что лучше выбрать ActiveX Dll, т.к. из нее легко получить некоторую информацию, которая нам нужна будет в дальнейшем. Хотя можно использовать и Standart EXE, разницы особой нет. Если почитать об ключах компиляции, то автор топика написал: , поэтому мы сами будем инициализировать рантайм. Об ограничениях неинициализированного ранайма я немного писал в предыдущем посте. Сама инициализация не нужна, если к примеру использовать эту DLL в VB6, т.к. рантайм (а точнее поток) уже инициализирован. Так что для обычных функций, вызываемых в том же потоке из VB6 такая DLL будет выполнять свои задачи на 100%. Именно поэтому можно в сети встретить много дисскусий что нативные DLL, созданные в VB6 не работают в других языках. Все дело в инициализации. Как же нам инициализировать поток для полноценной работы нашей DLL. Во-первых, нам нужно определить свою точку входа DllMain. Как это сделать? Для этого существует ключ ENTRY линкера. Вписываем имя нашей функции и наша DLL стартует с нее. Прототип этой функции должен быть следующим: Код (Visual Basic): Public Function DllMain(ByVal hInstDLL As Long, ByVal fdwReason As Long, ByVal lpvReserved As Long) As Long End Function В hInstDLL - передается базовый адрес загрузки модуля (он же hInstance, hModule), в fdwReason передается значение указывающее причину вызова этой функции. Существует 4 случая вызова этой функции, когда DLL загружается в адресное пространство процесса (DLL_PROCESS_ATTACH), когда создается новый поток в процессе (DLL_THREAD_ATTACH) и соответственно два парных противоположных случая при корректном завершении потока (DLL_THREAD_DETACH) и выгрузке DLL из памяти (DLL_PROCESS_DETACH), также корректном. lpReserved - нам не важен. Теперь при загрузке DLL будет вызываться наша функция и мы сможем делать инициализацию. С этим понятно.
Теперь представим ситуацию, что DLL загрузилась в АП процесса, а процесс создал поток и оба вызвали функцию Foo, что будет? Какое значение будет иметь переменная Temp после окончания потоков? Код (Visual Basic): ' Код DLL Dim Temp As Long Public Sub foo() Temp = App.ThreadID End Sub Все зависит от того, какой поток последним запишет значение в переменную Temp, а это нельзя знать точно. Возникла проблема - переменные уровня модуля стали разделяемыми, они доступны всем потокам процесса для модификации, а это может породить много ошибок (состояние гонки, блокировки и т.п.). К счастью есть выход из этой ситуации - использование локального хранилища потока (TLS) для хранения потокозависимых данных. Можно делать это вручную через специальные функции (TlsAlloc, TlsFree, TlsSetValue, TlsGetValue), либо поручить эту задачу компилятору, что более удобней. Для этого существует опция Threading model в свойствах проекта. Если там стоит Single Threaded, то все переменные будут общими, а если Apartment Threaded - то каждый поток получит свою копию переменных. С этим понятно. В нашем модуле нет общих переменных поэтому мы выбираем Single Threaded. Теперь по поводу инициализации рантайма. Методика инициализации рантайма для создания Native DLL, которая будет описана дальше, впервые была продемонстрирована и описана в проекте FireNativeDLL. Учитывая то, что ActiveX DLL работают в многопоточных программах (без труда можно работать с такой DLL например в Delphi или C++), то значит можно инициализировать поток пойдя методом создания объекта. После просмотра внутренностей ActiveX DLL, было выявлено что точка входа вызывает UserDllMain из рантайма, передавая первыми двумя параметрами два указателя: Итак, чтобы начать инициализацию нужно вызвать из нашей точки входа UserDllMain из VB6, но нужно достать 2 параметра. Пока мы этого делать не будем, т.к. одного вызова UserDllMain недостаточно, иначе можно было бы не заморачиваться а оставить как есть, она вызывается по умолчанию. Инициализация потока выполняется при создании объекта из ActiveX DLL. Для того чтобы создать объект нужно вызвать функцию DllGetClassObject из DLL. Давайте посмотрим как выглядит эта функция внутри, а заодно и другие экспортируемые функции: Функция DllGetClassObject пересылает данные в функцию VBDllGetClassObject из рантайма дополнительно передавая первыми тремя параметрами указатели. Видно что 2 указателя, передаваемые в UserDllMain первыми двумя параметрами, эквивалентны первым двум указателям передаваемым в VBDllGetClassObject, а третий параметр соответствует структуре VBHeader которая описывает проект. В моей версии рантайма первым параметром (lphInst) передается указатель в который UserDllMain записывает hInstance библиотеки, второй (lpUnk) параметр не используется ни одной функцией. Возможно что в каких-нибудь других версиях рантайма эти параметры будут использоваться по-другому, поэтому стоит передать правильные значения. Теперь нужно получить адреса этих данных. Для этого, анализируя опкоды, получаем их к примеру из DllGetClassObject: Адрес VBHeader будет равен адресу функции DllGetClassObject + 2 (пропускаем опкод POP EAX, и PUSH) Адрес lpUnk будет равен адресу функции DllGetClassObject + 7 Адрес lphInstance будет равен адресу функции DllGetClassObject + 12 Получить адрес из UserDllMain очень просто, т.к. нам известен хендл библиотеки (он передается первым параметром); вызываем GetProcAddress и получаем адрес DllGetClassObject. Далее получаем значения через GetMem4. Хочу отметить что все API функции должны быть объявлены в библиотеке типов, для этого я скомпилировал DllInitialize.tlb, после компиляции она не нужна. Для вызова VBDllGetClassObject используем в качестве IID - IUnknown, в качестве CLSID - IID_NULL. Также для инициализации COM должна быть вызвана функция CoInitialize. Если теперь попробовать собрать DLL, то все будет работать, но нужно учитывать что при первом вызове VBDllGetClassObject все модульные переменные инициализируются значениями по умолчанию. Поэтому нужно полученные переменные до вызова сохранить в локальных переменных, а после уже можно сохранять в модульные. Также нужно учитывать потоковую модель проекта: для Apartment, в функции DllMain не должно быть обращений к модульным переменным.
Для обеих моделей я создал 2 модуля: Для single threaded: Код (Visual Basic): ' modMainDLL.bas - инициализация DLL (Single thread) ' © Кривоус Анатолий Анатольевич (The trick), 2014 Option Explicit Private Type uuid data1 As Long data2 As Integer data3 As Integer data4(7) As Byte End Type Public hInstance As Long Private lpInst_ As Long Private lpUnk_ As Long Private lpVBHdr_ As Long ' Точка входа Public Function DllMain(ByVal hInstDll As Long, ByVal fdwReason As Long, ByVal lpvReserved As Long) As Long Dim lpProc As Long Dim lpInst As Long Dim lpUnk As Long Dim lpVBHdr As Long ' При создании процесса инициализируем адреса нужных переменных If fdwReason = DLL_PROCESS_ATTACH Then ' Получаем нужные нам данные, VBHeader, и два указателя необходимых для инициализации lpProc = GetProcAddress(hInstDll, "DllGetClassObject") If lpProc = 0 Then Exit Function GetMem4 ByVal lpProc + 2, lpVBHdr GetMem4 ByVal lpProc + 7, lpUnk GetMem4 ByVal lpProc + 12, lpInst DllMain = InitRuntime(lpInst, lpUnk, lpVBHdr, hInstDll, fdwReason, lpvReserved) lpInst_ = lpInst: lpUnk_ = lpUnk: lpVBHdr_ = lpVBHdr: hInstance = hInstDll ElseIf fdwReason = DLL_THREAD_ATTACH Then DllMain = InitRuntime(lpInst_, lpUnk_, lpVBHdr_, hInstDll, fdwReason, lpvReserved) Else vbCoUninitialize DllMain = UserDllMain(lpInst_, lpUnk_, hInstDll, fdwReason, ByVal lpvReserved) End If End Function Private Function InitRuntime(ByVal lpInst As Long, ByVal lpUnk As Long, ByVal lpVBHdr As Long, ByVal hInstDll As Long, _ ByVal fdwReason As Long, ByVal lpvReserved As Long) As Long Dim iid As uuid Dim clsid As uuid InitRuntime = UserDllMain(lpInst, lpUnk, hInstDll, fdwReason, ByVal lpvReserved) If InitRuntime Then vbCoInitialize ByVal 0& iid.data4(0) = &HC0: iid.data4(7) = &H46 ' IUnknown VBDllGetClassObject lpInst, lpUnk, lpVBHdr, clsid, iid, 0 ' Инициализация потока End If End Function Для apartment threaded: Код (Visual Basic): ' modMainDLL.bas - инициализация DLL (Apartment threaded) ' © Кривоус Анатолий Анатольевич (The trick), 2014 Option Explicit Private Type uuid data1 As Long data2 As Integer data3 As Integer data4(7) As Byte End Type Public hInstance As Long Private lpInst_ As Long Private lpUnk_ As Long Private lpVBHdr_ As Long ' Точка входа, здесь не должно быть обращения к внешним переменным, т.е. public, private, static Public Function DllMain(ByVal hInstDLL As Long, ByVal fdwReason As Long, ByVal lpvReserved As Long) As Long Dim iid As uuid Dim clsid As uuid Dim lpInst As Long Dim lpUnk As Long Dim lpVBHdr As Long Dim lpProc As Long ' При создании процесса или потока If fdwReason = DLL_PROCESS_ATTACH Or fdwReason = DLL_THREAD_ATTACH Then ' Получаем нужные нам данные, VBHeader, и два указателя необходимых для инициализаци ' Каждый поток содержит свои данные (публичные, статичные переменные и т.д.) lpProc = GetProcAddress(hInstDLL, "DllGetClassObject") If lpProc = 0 Then Exit Function GetMem4 ByVal lpProc + 2, lpVBHdr GetMem4 ByVal lpProc + 7, lpUnk GetMem4 ByVal lpProc + 12, lpInst ' Инициализация COM vbCoInitialize ByVal 0& ' Эта функция вызывается из ActiveX DLL DllMain = UserDllMain(lpInst, lpUnk, hInstDLL, fdwReason, ByVal lpvReserved) If DllMain = 0 Then Exit Function iid.data4(0) = &HC0: iid.data4(7) = &H46 ' IUnknown VBDllGetClassObject lpInst, lpUnk, lpVBHdr, clsid, iid, 0 ' Инициализация потока ' Тут глобальные и статичные переменные обнуляются, восстанавливаем их SetPublicVariable lpInst, lpUnk, lpVBHdr, hInstDLL Else vbCoUninitialize DllMain = DefMainDLL(hInstDLL, fdwReason, ByVal lpvReserved) End If End Function Private Sub SetPublicVariable(ByVal lpInst As Long, ByVal lpUnk As Long, ByVal lpVBHdr As Long, ByVal hInstDLL As Long) lpInst_ = lpInst: lpUnk_ = lpUnk: lpVBHdr_ = lpVBHdr: hInstance = hInstDLL End Sub Private Function DefMainDLL(ByVal hInstDLL As Long, ByVal fdwReason As Long, ByVal lpvReserved As Long) As Long DefMainDLL = UserDllMain(lpInst_, lpUnk_, hInstDLL, fdwReason, ByVal lpvReserved) End Function Итак, теперь мы умеем инициализировать рантайм и можем приступить к компиляции нативной DLL. В файл проекта добавляем вот эти строки позволяющие указать дополнительные ключи компилятора и линкера: Код (Text): [VBCompiler] LinkSwitches= /ENTRY:DllMain /EXPORT:Brightness /EXPORT:Contrast /EXPORT:Saturation /EXPORT:GaussianBlur /EXPORT:EdgeDetect /EXPORT:Sharpen /EXPORT:Emboss /EXPORT:Minimum /EXPORT:Maximum /EXPORT:FishEye И настраиваем потоковую модель проекта в single threaded, также нужно в проект добавить класс, иначе проект не скомпилируется. По желанию можно также добавить функциональность ActiveX DLL, тогда можно с этой DLL работать и как с ActiveX, и как с обычной нативной импортируя функции.
Для тестирования DLL была написана мини-программа: Код (Visual Basic): ' Демонстрация использования многопоточности в NativeDLL на примере графических эффектов ' © Кривоус Анатолий Анатольевич (The trick), 2014 Option Explicit ' Структура, идентичная объявленной в DLL Private Type ThreadData pix() As Byte value As Single percent As Single End Type Private Type BITMAPINFOHEADER biSize As Long biWidth As Long biHeight As Long biPlanes As Integer biBitCount As Integer biCompression As Long biSizeImage As Long biXPelsPerMeter As Long biYPelsPerMeter As Long biClrUsed As Long biClrImportant As Long End Type Private Type BITMAPINFO bmiHeader As BITMAPINFOHEADER bmiColors As Long End Type Private Type OPENFILENAME lStructSize As Long hwndOwner As Long hInstance As Long lpstrFilter As Long lpstrCustomFilter As Long nMaxCustFilter As Long nFilterIndex As Long lpstrFile As Long nMaxFile As Long lpstrFileTitle As Long nMaxFileTitle As Long lpstrInitialDir As Long lpstrTitle As Long Flags As Long nFileOffset As Integer nFileExtension As Integer lpstrDefExt As Long lCustData As Long lpfnHook As Long lpTemplateName As Long End Type Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameW" (pOpenfilename As OPENFILENAME) As Long Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As Long) As Long Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long Private Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, lpExitCode As Long) As Long Private Const STILL_ACTIVE As Long = &H103& Private Const INFINITE As Long = -1& Dim hLib As Long ' hInstance библиотеки Dim td As ThreadData ' Данные потока Dim hThread As Long ' Описатель потока Dim pic As StdPicture ' Изображение Dim bi As BITMAPINFO ' Информация об изображении Dim quene As Boolean ' Флаг очереди ' // Нажатие на кнопку загрузки рисунка Private Sub cmdLoad_Click() ' Загружаем LoadImage End Sub ' // Загрузка формы Private Sub Form_Load() ' Загружаем DLL ChDir App.Path: ChDrive App.Path hLib = LoadLibrary(StrPtr("..\GraphicsDLL\GraphicsDLL.dll")) If hLib = 0 Then MsgBox "Неудалось загрузить DLL": End ' Загружаем картинку по умолчанию LoadImage "defpic.jpg" End Sub ' // Выгрузка формы Private Sub Form_Unload(cancel As Integer) ' Если поток выполняется ждем завершения If hThread Then WaitForSingleObject hThread, INFINITE ' Выгружаем библиотеку FreeLibrary hLib End Sub ' // Запускаем эффект Private Sub RunEffect() Select Case cboEffect.ListIndex Case 0: picImage.PaintPicture pic, 0, 0 ' Исходное изображение Case 1: RunProcedure "Brightness", sldValue / 50 - 1 ' Яркость Case 2: RunProcedure "Contrast", sldValue / 50 ' Контрастность Case 3: RunProcedure "Saturation", sldValue / 100 ' Насыщенность Case 4: RunProcedure "GaussianBlur", sldValue / 2 ' Размытие Case 5: RunProcedure "EdgeDetect", sldValue / 2 + 1 ' Выделение контуров Case 6: RunProcedure "Sharpen", sldValue / 3 ' Резкость Case 7: RunProcedure "Emboss", sldValue / 10 ' Тиснение Case 8: RunProcedure "Minimum", sldValue / 10 ' Минимум Case 9: RunProcedure "Maximum", sldValue / 10 ' Максимум Case 10: RunProcedure "FishEye", sldValue / 100 ' Рыбий глаз End Select End Sub ' // Загрузить картинку Private Sub LoadImage(Optional ByVal fileName As String) Dim ofn As OPENFILENAME Dim title As String Dim out As String Dim filter As String Dim i As Long Dim dx As Long Dim dy As Long ' Если поток выполняется ждем завершения If hThread Then WaitForSingleObject hThread, INFINITE ' Если имя файла не задано, то показываем диалог открытия файла If Len(fileName) = 0 Then ofn.nMaxFile = 260 out = String(260, vbNullChar) title = "Open image" filter = "Picture file" & vbNullChar & "*.bmp;*.jpg" & vbNullChar ofn.hwndOwner = Me.hWnd ofn.lpstrTitle = StrPtr(title) ofn.lpstrFile = StrPtr(out) ofn.lStructSize = Len(ofn) ofn.lpstrFilter = StrPtr(filter) If GetOpenFileName(ofn) = 0 Then Exit Sub ' Получаем имя файла i = InStr(1, out, vbNullChar, vbBinaryCompare) fileName = Left$(out, i - 1) End If On Error Resume Next ' Загружаем картинку Set pic = LoadPicture(fileName) If Err.Number Then MsgBox "Ошибка загрузки изображения", vbCritical: Exit Sub On Error GoTo 0 ' Установка постоянных атрибутов картинки bi.bmiHeader.biSize = Len(bi.bmiHeader) bi.bmiHeader.biBitCount = 32 bi.bmiHeader.biHeight = ScaleY(pic.Height, vbHimetric, vbPixels) bi.bmiHeader.biWidth = ScaleX(pic.Width, vbHimetric, vbPixels) bi.bmiHeader.biPlanes = 1 ' Массив пикселей ReDim td.pix(bi.bmiHeader.biWidth * 4 - 1, bi.bmiHeader.biHeight - 1) ' Проверка размеров If bi.bmiHeader.biWidth > picCanvas.ScaleWidth Then hsbScroll.Max = bi.bmiHeader.biWidth - picCanvas.ScaleWidth hsbScroll.Visible = True dx = -hsbScroll.value Else dx = (picCanvas.ScaleWidth - bi.bmiHeader.biWidth) / 2 hsbScroll.value = 0: hsbScroll.Visible = False End If If bi.bmiHeader.biHeight > picCanvas.ScaleHeight Then vsbScroll.Max = bi.bmiHeader.biHeight - picCanvas.ScaleHeight vsbScroll.Visible = True dy = -vsbScroll.value Else dy = (picCanvas.ScaleHeight - bi.bmiHeader.biHeight) / 2 vsbScroll.value = 0: vsbScroll.Visible = False End If ' Перемещаем картинку picImage.Move dx, dy, bi.bmiHeader.biWidth, bi.bmiHeader.biHeight ' Отображаем ее cboEffect.ListIndex = 0: RunEffect End Sub ' // Запустить эффект в другом потоке Private Sub RunProcedure(Name As String, ByVal value As Single) Dim lpProc As Long ' Если в очереди уже есть вызов выходим If quene Then Exit Sub ' Если поток активен, то ставим в очередь текущий вызов и выходим If hThread Then quene = True: Exit Sub ' Получаем адрес функции lpProc = GetProcAddress(hLib, Name) If lpProc = 0 Then MsgBox "Невозможно найти функцию": Exit Sub ' Устанавливаем значение эффекта td.value = value ' Получаем пиксели рисунка GetDIBits picCanvas.hdc, pic.Handle, 0, bi.bmiHeader.biHeight, td.pix(0, 0), bi, 0 ' Создаем поток hThread = CreateThread(ByVal 0&, 0, lpProc, td, 0, 0) ' Включаем таймер прогрессбара tmrUpdate.Enabled = True End Sub ' // Изменение величины эффекта Private Sub sldValue_Change() RunEffect End Sub ' // Изменение типа эффекта Private Sub cboEffect_Click() RunEffect End Sub ' // Таймер обновления Private Sub tmrUpdate_Timer() Dim status As Long ' Устанавливаем процент prgProgress.value = td.percent ' Получаем код завершения потока GetExitCodeThread hThread, status ' Если поток активен, выходим If status = STILL_ACTIVE Then Exit Sub ' Поток завершился, отключаем таймер tmrUpdate.Enabled = False If status Then ' Вызов удачен ' Обновляем изображение SetDIBitsToDevice picImage.hdc, 0, 0, bi.bmiHeader.biWidth, bi.bmiHeader.biHeight, 0, 0, 0, bi.bmiHeader.biHeight, td.pix(0, 0), bi, 0 picImage.Refresh Else ' При неудаче (функция эффекта возвратила 0) MsgBox "Функция потерпела неудачу", vbExclamation End If ' Закрываем описатель CloseHandle hThread ' Поток завершен hThread = 0 ' Если в очереди был вызов, то вызываем If quene Then quene = False: RunEffect End Sub ' // Скроллбары ----------------------------+ Private Sub vsbScroll_Change() ' | picImage.Top = -vsbScroll.value ' | End Sub ' | Private Sub vsbScroll_Scroll() ' | vsbScroll_Change ' | End Sub ' | Private Sub hsbScroll_Change() ' | picImage.Left = -hsbScroll.value ' | End Sub ' | Private Sub hsbScroll_Scroll() ' | hsbScroll_Change ' | End Sub ' | ' // ---------------------------------------+
Программа достаточно простая, все действия прокомментированы. Основные моменты я дополнительно поясню. При загрузке формы загружается наша DLL, и хендл библиотеки сохраняется в переменной hLib. Далее загружается изображение по умолчанию, расположенное в папке проекта. В процедуре загрузки изображения (LoadImage), заполняются основные поля структуры BITMAPINFO и выделяется массив под пиксели рисунка, для того чтобы потом можно было получить их через GetDiBits. Процедура RunEffect запускает функцию из DLL в отдельном потоке (RunProcedure). Для исключения запуска нескольких потоков в процедуре RunProcedure стоит проверка, если поток запущен, то установить переменную флаг (quene) и выйти не запуская ничего. Если поток не запущен, то получить пиксели через GetDiBits, и подготовив данные для потока (td), запустить функцию в отдельном потоке. Также при создании включается таймер обновления состояния. В процедуре таймера обновляется состояние прогрессбара исходя из значения переменной td.percent, и если поток успешно закончил свое выполнение (функция вернула не 0) обновляем данные в пикчербоксе через SetDIBitsToDevice. При окончании, если в переменной quene было True, то запускаем эффект, это позволит изменять значение величины эффекта или сам эффект пока идет обработка. Как видно из примера многопоточность отлично работает в VB6. К тому же эту DLL можно использовать в любом ЯП. В следующей части я опишу пример внедрения DLL и переопределение оконной процедуры, что даст возможность отслеживать различные события в других приложениях, перехватывать API функции и многое другое. Все вышеописанное является моим личным исследованием и поэтому могут быть любые "подводные камни", о которых я не знаю. О любых багах можете сообщать мне, я постараюсь решить. Отдельную благодарность хотелось бы выразить Владиславу Петровскому (aka. Хакер), за открытие недокументированных ключей компилятора/компоновщика.
Часть 3 - внедрение в чужой процесс. В прошлой части я написал о возможности создания потока в DLL, и о методе создания нативной DLL на VB6. Также я написал о том, что такая DLL будет работать в любом приложении, но примера не привел. В этой части мы напишем DLL которая будет выполняться в чужом 32-разрядном процессе и выполнять там наш код. В качестве примера сделаем приложение которое будет осуществлять сабклассинг окна в другом потоке и передавать в наше приложение сообщения, которые мы сможем обработать. Напишу сразу - DLL только для примера и не предназначена для работы в приложениях, т.к. имеются недостатки которые в качестве экономии кода я не устранял. Я решил сделать 3 случая использования: Ограничение минимального размера перекрывающегося окна. Отслеживания нажатий/отпусканий кнопок мыши в окне. Лог сообщений. Итак, сначала нужно придумать механизм взаимодействия между процессами. Я решил пойти следующим путем: Для обмена данными между приложениями будем использовать проецированный в память файл. Для передачи сообщения от процесса-"жертвы" нашему приложению, будем использовать новое зарегистрированное сообщение. Для уведомления о завершении сабклассинга передавать сообщение будем в другую сторону. Теперь нужно продумать как осуществлять запуск. Ставим хук WH_GETMESSAGE на поток в котором содержится окно. Теперь наша DLL загрузится в АП процесса жертвы. В callback функции GetMsgProc при первом вызове будем инициализировать данные и устанавливать сабклассинг на нужное окно, для обмена как было сказано выше используем файл-маппинг.
Итак код: Код (Visual Basic): ' modSubclassDLL.bas - процедуры хука и сабклассинга ' © Кривоус Анатолий Анатольевич (The trick), 2014 Option Explicit ' Эту структуру мы будем прередавать между процессами через файловое представление Public Type MsgData hWnd As Long ' Хендл сабклассируемого окна uMsg As Long ' Сообщение wParam As Long ' Параметры lParam As Long ' - return As Long ' Возвращаемое значение defCall As Long ' Вызывать ли изначальную процедуру End Type Private Declare Function OpenFileMapping Lib "kernel32" Alias "OpenFileMappingW" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal lpName As Long) As Long Private Declare Function OpenMutex Lib "kernel32" Alias "OpenMutexW" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal lpName As Long) As Long Private Declare Function MapViewOfFile Lib "kernel32" (ByVal hFileMappingObject As Long, ByVal dwDesiredAccess As Long, ByVal dwFileOffsetHigh As Long, ByVal dwFileOffsetLow As Long, ByVal dwNumberOfBytesToMap As Long) As Long Private Declare Function UnmapViewOfFile Lib "kernel32" (ByVal lpBaseAddress As Long) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Declare Function GetMem4 Lib "msvbvm60" (Src As Any, Dst As Any) As Long Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long Private Declare Function ReleaseMutex Lib "kernel32" (ByVal hMutex As Long) As Long Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Integer, lParam As Any) As Long Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function SetProp Lib "user32" Alias "SetPropW" (ByVal hWnd As Long, ByVal lpString As Long, ByVal hData As Long) As Long Private Declare Function RemoveProp Lib "user32" Alias "RemovePropW" (ByVal hWnd As Long, ByVal lpString As Long) As Long Private Declare Function GetProp Lib "user32" Alias "GetPropW" (ByVal hWnd As Long, ByVal lpString As Long) As Long Private Declare Function GlobalAddAtom Lib "kernel32" Alias "GlobalAddAtomW" (ByVal lpString As Long) As Integer Private Declare Function GlobalDeleteAtom Lib "kernel32" (ByVal nAtom As Integer) As Integer Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageW" (ByVal lpString As Long) As Long Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcW" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Private Const GWL_WNDPROC As Long = (-4) Private Const INFINITE As Long = -1& Private Const MUTEX_ALL_ACCESS As Long = &H1F0001 Private Const FILE_MAP_READ As Long = &H4 Private Const FILE_MAP_WRITE As Long = &H2 Private Const WAIT_FAILED As Long = -1& Private WM_SENDMESSAGE As Long ' Наше сообщение для обмена с основной программой. Отсылая из текущего потока это сообщение ' в наше приложение (TestSubclassDLL), мы уведомляем приложение через SendMessage о том, что ' пришло новое сообщение, параметры которого записаны в файловое представление. Передавая из ' главного (TestSubclassDLL) приложения сюда это сообщение, мы уведомляем о том, что нужно ' снять сабклассинг и выполнить деинициализацию. Dim hMutex As Long ' Описатель мьютекса для синхронизации чтения/записи общих данных Dim hMap As Long ' Хендл файлового отображения Dim lpShrdData As Long ' Адрес общих данных Dim hWndServer As Long ' Хендл окна для приема и обработки сообщений Dim hWndHook As Long ' Хендл сабклассируемого окна в этом процессе Dim hHook As Long ' Хендл хука, для передачи в CallNextHookEx Dim aPrevProc As Integer ' Атом имени свойства изначальной оконной процедуры Dim init As Boolean ' Инициализирован ли сабклассинг Dim disabled As Boolean ' Сабклассинг окончен. ' // Процедура хука Public Function GetMsgProc(ByVal code As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Dim prevProc As Long ' Если не инициализирован сабклассинг - инициализируем If Not (init Or disabled) Then ' Открываем проекцию hMap = OpenFileMapping(FILE_MAP_WRITE, False, StrPtr("TrickSubclassFileMap")) If hMap = 0 Then MsgBox "Невозможно открыть проекцию", vbCritical: Clear: Exit Function ' Проецируем lpShrdData = MapViewOfFile(hMap, FILE_MAP_WRITE, 0, 0, 0) CloseHandle hMap: hMap = 0 If lpShrdData = 0 Then MsgBox "Невозможно отобразить представление", vbCritical: Clear: Exit Function ' Открываем синхронизирующий мьютекс hMutex = OpenMutex(MUTEX_ALL_ACCESS, False, StrPtr("TrickSubclassMutex")) If hMutex = 0 Then MsgBox "Невозможно отрыть мьютекс", vbCritical: Clear: Exit Function ' Регистрация сообщения WM_SENDMESSAGE = RegisterWindowMessage(StrPtr(WM_SENDMESSAGE)) If WM_SENDMESSAGE = 0 Then MsgBox "Невозможно Зарегистрировать сообщение", vbCritical: Clear: Exit Function ' Добавляем/получаем атом для сохранения предыдущей оконной процедуры aPrevProc = GlobalAddAtom(StrPtr("prevProc")) If aPrevProc = 0 Then MsgBox "Невозможно добавить атом", vbCritical: Clear: Exit Function ' Захватываем мьютекс. Если например в главном приложении еще не произошел выход из SetWindowsHookEx, то ' еще неизвестен хендл хука, а т.к. у нас там уже захвачен этот мьютекс, то этот поток будет ждать пока ' мьютекс не освободится, что произойдет только после записи хендля хука в общую память и остальных данных If WaitForSingleObject(hMutex, INFINITE) = WAIT_FAILED Then MsgBox "Ошибка ожидания", vbCritical: Clear: Exit Function ' Получаем хендл окна, которое будет принимать сообщения GetMem4 ByVal lpShrdData, hWndServer ' Получаем хендл сабклассируемого окна GetMem4 ByVal lpShrdData + 4, hWndHook ' Получаем хендл хука GetMem4 ByVal lpShrdData + 8, hHook ' Освобождаем мьютекс ReleaseMutex hMutex ' Получаем адрес оконной процедуры и задаем новый prevProc = SetWindowLong(hWndHook, GWL_WNDPROC, AddressOf WndProc) If prevProc = 0 Then MsgBox "Невозможно заменить оконную процедуру", vbCritical: Clear: Exit Function ' Установка свойства окна SetProp hWndHook, CLng(aPrevProc) And &HFFFF&, prevProc ' Успех init = True End If ' Передаем на обработку другим процедурам GetMsgProc = CallNextHookEx(hHook, code, wParam, lParam) End Function ' // Деинициализация Public Sub Clear() If hMutex Then CloseHandle (hMutex): hMutex = 0 If lpShrdData Then UnmapViewOfFile (lpShrdData): lpShrdData = 0 If hWndHook Then RemoveProp hWndHook, CLng(aPrevProc) And &HFFFF&: hWndHook = 0 If aPrevProc Then GlobalDeleteAtom (aPrevProc): aPrevProc = 0 init = False End Sub ' // Оконная процедура Private Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Dim sendData As MsgData Dim prevProc As Long ' Проверяем не снятие ли сабклассинга If uMsg = WM_SENDMESSAGE Then ' Получаем предыдущий адрес процедуры prevProc = GetProp(hWnd, CLng(aPrevProc) And &HFFFF&) ' Устанавливаем его оконной процедуре SetWindowLong hWnd, GWL_WNDPROC, prevProc ' Очистка Clear ' Отключаем сабклассинг ' Возможна ситуация когда будет вызвана GetMsgProc, до того, как будет снят хук в главно приложении ' этот флаг предотвращает повторную инициализацию данных. disabled = True Exit Function ' Теперь из главного приложения будет вызвана UnhookWindowsHookEx и наша DLL будет выгружена из памяти. End If ' Формируем запрос sendData.hWnd = hWnd sendData.uMsg = uMsg sendData.wParam = wParam sendData.lParam = lParam sendData.defCall = True ' Захватываем мьютекс If WaitForSingleObject(hMutex, INFINITE) = WAIT_FAILED Then MsgBox "Ошибка ожидания", vbCritical: Clear: Exit Function CopyMemory ByVal lpShrdData + 12, sendData, Len(sendData) ' Освобождаем мьютекс ReleaseMutex hMutex ' Отправляем сообщение главному окну SendMessage hWndServer, WM_SENDMESSAGE, 0, ByVal 0 ' Получаем результат обработки If WaitForSingleObject(hMutex, INFINITE) = WAIT_FAILED Then MsgBox "Ошибка ожидания", vbCritical: Clear: Exit Function CopyMemory sendData, ByVal lpShrdData + 12, Len(sendData) ' Освобождаем мьютекс ReleaseMutex hMutex ' Следует ли обрабатывать его дальше If sendData.defCall Then prevProc = GetProp(hWnd, CLng(aPrevProc) And &HFFFF&) WndProc = CallWindowProc(prevProc, sendData.hWnd, sendData.uMsg, sendData.wParam, sendData.lParam) Else WndProc = sendData.return End If End Function
Разберем подробно код. В процедуре инициализации проверяем флаги инициализации и отключения сабклассинга. Если какой-либо True, то значит либо сабклассинг установлен, либо закончен. Иначе начинаем инициализацию. Первым делом открываем файл-маппинг и проецируем представление на АП процесса. Для избежания состояния гонки используем синхронизирующий объект мьютекс. Потом регистрируем сообщение WM_SENDMESSAGE для обмена в системе и получаем его номер. Для хранения адреса предыдущей оконной процедуры я решил использовать свойство окна, хотя можно было бы использовать и переменную модуля, т.к. за раз можно только перехватить только одно окно в этой реализации. Для ускоренного доступа к свойству я использую атом, поэтому регистрируем его с именем prevProc. Потом пытаемся захватить мьютекс. Когда это удается, то общие данные доступны только для этого потока, никакой другой поток не сможет что-то записать туда и мы избежим состояния гонки. Из файл-маппинга достаем нужные нам данные (хендл главного окна нашего приложения, хендл сабклассируемого окна и хендл хука, его нужно передать в CallNextHookEx). Позже освобождаем мьютекс, и устанавливаем адрес оконной процедуры на наш (сабклассируем окно). Теперь все сообщения предназначенные для окна пойдут в процедуру WndProc. Разберем процедуру WndProc. Для начала разберем структуру файл-маппинга: Проверяем сообщение, если это наше зарегистрированное, то его может отправить только наше приложение при снятии сабклассинга, поэтому выполняем деинициализацию. Иначе формируем данные сообщения и, захватив мьютекс, пишем их в файл маппинг со смещения 0x0Ch (1210) и передаем их в главное окно нашего приложения для обработки. Т.к. мы используем SendMessage для передачи, выход из нее не произойдет пока мы в своем приложении не завершим обработку этого сообщения. При возврате проверяем флаг defCall, который отвечает пускать ли сообщение дальше в старую оконную процедуру или нет. Теперь разберем главное приложение. При загрузке формы вызываем функцию Initialize, которая инициализирует данные необходимые для сабклассинга. Во-первых создаем мьютекс для синхронизации, файл-маппинг для обмена данными и проецируем его представление, регистрируем сообщение WM_SENDMESSAGE, загружаем библиотеку с процедурой хука и сабклассим главное окно для приема сообщений. Далее при успехе загружаем иконку для состояний сабклассинга и загружаем список сообщений. Для старта сабклассинга нужно зажать кнопку мыши на контроле picIcon и переместить ее на нужный контрол. При этом идет получение хендла окна под курсором и его маркировка рамкой. Для рамки берется либо регион окна, если он существует, в противном случае он создается на основе прямоугольника окна. Регион обрисовывается рамкой через R2_XOR наложение (vbXorPen), для снятия пометки просто еще раз рисуется рамка. При отпускании кнопки над окном, получаем его хендл и запускаем функцию StartSubclass. В этой процедуре мы проверяем поток (в своем потоке я запретил перехватывать сообщения т.к. может произойти рекурсия и вылет), при необходимости устанавливаем сабклассинг. Далее открываем процесс-"жертву", т.к. нам понадобится чтение и запись в его адресное пространство при обработке сообщений, передавая флаги PROCESS_VM_OPERATION, PROCESS_VM_WRITE, PROCESS_VM_READ. Теперь для того чтобы начать сабклассинг нужно подготовить данные для процесса-"жертвы", поэтому захватываем мьютекс и после этого ставим хук WH_GETMESSAGE в потоке процесса-"жертвы". После этого копируем данные в общую память, можем быть уверенными что поток-"жертва" не будет оттуда читать. Даже если процедура GetMsgProc начнет свое выполнение она будет ждать в функции WaitForSingleObject пока мы не освободим мьютекс. После копирования освобождаем мьютекс, теперь все готово. После получения очередного сообщения окном-"жертвой" мы передаем его нашему приложению из процедуры WndProc находящейся в DLL, которая загружена в АП процесса-"жертвы". В нашем приложении мы при получении WM_SENDMESSAGE копируем данные из общей памяти и передаем их на обработку методу формы WndProc. В этом методе, мы в зависимости от выбранной вкладки так или иначе обрабатываем сообщения. В первом случае мы ограничиваем минимальный рамер окна, посредством обработки сообщения WM_GETMINMAXINFO. Нужно помнить что адреса передаваемые в оконную процедуру - это адреса в АП процесса-"жертвы", для нашего процесса они недействительны. Из-за этого мы вместо CopyMemory используем ReadProcessMemory и WriteProcessMemory. Во-втором обрабатываем WM_LBUTTONDOWN и WM_LBUTTONUP и в своем процессе помечаем вкладку. В-третьем просто заносим название сообщения и параметры в список. Для остановки сабклассинга нужно нажать на иконку, которая будет помечена как "STOP". Тем самым вызывается функция StopSubclass. В ней мы передаем окну-"жертве" сообщение WM_SENDMESSAGE, тем самым говоря что мы заканчиваем сабклассинг. В DLL, в функции WndProc, как я описал выше, мы производим деинициализацию. После деинициализации происходит возврат в наше приложение и снимается хук посредством вызова UnhookWindowsHookEx. После система выгружает нашу DLL из памяти процесса-"жертвы". Как мы увидели DLL, написанная на VB6, отлично работает в чужих программах и потоках. Данная DLL написана только для тестирования и демонстрации возможностей VB6. Я не ставил перед собой задачи написания законченной DLL для использования в проектах, поэтому DLL намеренно обладает ограничениями и имеет неправильную архитектуру (нельзя делать множественный сабклассинг и другие ограничения и баги), отсутствуют проверки. Для демонстрации возможностей этого достаточно. Как мы могли убедиться что многопоточность вполне работает в программах написанных на VB6, и DLL, написанные на VB6 работают в любых программах.
Часть 4 - многопоточность в Standart EXE. Сейчас я опять буду говорить о многопоточности, на этот раз в Standart EXE. Сразу скажу что все о чем я пишу является моим личным исследованием и может в чем-то не соответствовать действительности; также из-за моего недостатка времени я буду дополнять этот пост по мере дальнейшего прогресса в исследовании данного вопроса. Итак начнем. Как я говорил до этого для того чтобы многопоточность работала нужно инициализировать рантайм. Без инициализации мы можем работать очень ограниченно, в том смысле что COM не будет работать, т.е. грубо говоря вся мощь бейсика будет недоступна. Можно работать с API, объявленными в tlb, некоторыми функциями, также убирая проверку __vbaSetSystemError, можно использовать Declared-функции. Все предыдущие публикации показывали работу в отдельных DLL, и мы легко могли инициализировать рантайм используя VBDllGetClassObject функцию для этого. Сегодня мы попытаемся инициализировать рантайм в обычном EXE, т.е. не используя внешние зависимости. Не для кого не секрет что любое приложение написанное в VB6 состоит из хидера проекта, в котором содержится очень много информации о проекте которую рантайм использует для работы: Код (Visual Basic): Type VbHeader szVbMagic As String * 4 wRuntimeBuild As Integer szLangDll As String * 14 szSecLangDll As String * 14 wRuntimeRevision As Integer dwLCID As Long dwSecLCID As Long lpSubMain As Long lpProjectInfo As Long fMdlIntCtls As Long fMdlIntCtls2 As Long dwThreadFlags As Long dwThreadCount As Long wFormCount As Integer wExternalCount As Integer dwThunkCount As Long lpGuiTable As Long lpExternalCompTable As Long lpComRegisterData As Long bszProjectDescription As Long bszProjectExeName As Long bszProjectHelpFile As Long bszProjectName As Long End Type В этой структуре большое количество полей описывать все я не буду, отмечу только что эта структура ссылается на множество других структур. Некоторые из них нам понадобятся в дальнейшем, например поле lpSubMain, в котором содержится адрес процедуры Main, если она определена, иначе там 0. Подавляющее большинство EXE файлов начинаются со следующего кода: Код (ASM): PUSH xxxxxxxx CALL MSVBVM60.ThunRTMain Как раз xxxxxxxx указывает на структуру VBHeader. Эта особенность позволит найти эту структуру внутри EXE для инициализации рантайма. В одной из предыдущих частей я описывал как достать из ActiveX DLL эту структуру - для этого нужно было считать данные в одной из экспортируемых функций (к примеру DllGetClassObject). Для получения из EXE - мы также воспользуемся тем-же методом. Для начала нужно найти точку входа (entry point), т.е. адрес с которого начинается выполнение EXE. Этот адрес можно получить из структуры IMAGE_OPTIONAL_HEADER - поле AddressOfEntryPoint. Сама структура IMAGE_OPTIONAL_HEADER расположена в PE заголовке, а PE заголовок находится по смещению заданному в поле e_lfanew структуры IMAGE_DOS_HEADER, ну а структура IMAGE_DOS_HEADER расположена по адресу App.hInstance (или GetModuleHandle). Указатель на VbHeader будет лежать по смещению AddressOfEntryPoint + 1, т.к. опкод команды push в данном случае 0x68h. Итак, собирая все вместе, получим функцию для получения хидера: Код (Visual Basic): ' // Get VBHeader structure Private Function GetVBHeader() As Long Dim ptr As Long ' Get e_lfanew GetMem4 ByVal hModule + &H3C, ptr ' Get AddressOfEntryPoint GetMem4 ByVal ptr + &H28 + hModule, ptr ' Get VBHeader GetMem4 ByVal ptr + hModule + 1, GetVBHeader End Function Теперь если передать эту структуру функции VBDllGetClassObject в новом потоке, то, грубо говоря, эта функция запустит наш проект на выполнение согласно переданной структуре. Конечно смысла в этом мало - это тоже самое что начать выполнение приложения заново в новом потоке. Например если была задана функция Main, то и выполнение начнется опять с нее, а если была форма, то с нее. Нужно как-то сделать так, чтобы проект выполнялся с другой, нужной нам, функции. Для этого можно изменить поле lpSubMain структуры vbHeader. Я тоже сначала сделал так, но это ничего не дало. Как выяснилось, внутри рантайма есть один глобальный объект, который хранит ссылки на проекты и связанные с ними объекты и если передать тот же самый хидер в VBDllGetClassObject, то рантайм проверит, не загружался ли такой проект, и если загружался, то просто запустит новую копию без разбора структуры vbHeader, на основании предыдущего разбора. Поэтому я решил поступить так - можно скопировать структуру vbHeader в другое место и использовать ее. Сразу замечу, что в этой структуре последние 4 поля - это смещения относительно начала структуры, поэтому при копировании струкутуры их нужно будет скорректировать. Если теперь попробовать передать эту структуру в VBDllGetClassObject, то все будет отлично если в качестве стартапа установлена Sub Main, если же форма, то будет запущена и форма и после нее Main. Для исключения такого поведения нужно поправить кое-какие данные на которые ссылается хидер. Я пока точно не знаю что это за данные, т.к. не разбирался в этом, но "поковырявшись" внутри рантайма я нашел их место положение. Поле lpGuiTable структуры vbHeader ссылается на список структур tGuiTable, которые описывают формы в проекте. Структуры идут последовательно, число структур соответствует полю wFormCount структуры vbHeader. В сети я так и не нашел нормальное описание структуры tGuiTable, вот что есть: Код (Visual Basic): Type tGuiTable lStructSize As Long uuidObjectGUI As uuid Unknown1 As Long Unknown2 As Long Unknown3 As Long Unknown4 As Long lObjectID As Long Unknown5 As Long fOLEMisc As Long uuidObject As uuid Unknown6 As Long Unknown7 As Long aFormPointer As Long Unknown8 As Long End Type Как выяснилось внутри рантайма есть код, который проверяет поле Unknown5 каждой структуры: Я проставил комментарии; из них видно что Unknown5 содержит флаги и если установлен 5-й бит, то происходит запись ссылки на какой-то объект, заданный регистром EAX, в поле со смещением 0x30 объекта заданного регистром EDX. Что за объекты - я не знаю, возможно позже разберусь с этим, нам важен сам факт записи какого-то значения в поле со смещением 0x30. Теперь, если дальше начать исследовать код то можно наткнутся на такой фрагмент: Скажу что объект на который указывает ESI, тот же самый объект что в предыдущей рассматриваемой процедуре (регистр EDX). Видно что тестируется значение этого поля на -1 и на 0, и если там любое из этих чисел то запускается процедура Main (если она задана); иначе запускается первая форма. Итак, теперь чтобы гарантированно запускать только Sub Main, мы изменяем флаг lpGuiTable.Unknown5, сбрасывая пятый бит. Для установки новой Sub Main и модификации флага я создал отдельную процедуру: Код (Visual Basic): ' // Modify VBHeader to replace Sub Main Private Sub ModifyVBHeader(ByVal newAddress As Long) Dim ptr As Long Dim old As Long Dim flag As Long Dim count As Long Dim size As Long ptr = lpVBHeader + &H2C ' Are allowed to write in the page VirtualProtect ByVal ptr, 4, PAGE_READWRITE, old ' Set a new address of Sub Main GetMem4 newAddress, ByVal ptr VirtualProtect ByVal ptr, 4, old, 0 ' Remove startup form GetMem4 ByVal lpVBHeader + &H4C, ptr ' Get forms count GetMem4 ByVal lpVBHeader + &H44, count Do While count > 0 ' Get structure size GetMem4 ByVal ptr, size ' Get flag (unknown5) from current form GetMem4 ByVal ptr + &H28, flag ' When set, bit 5, If flag And &H10 Then ' Unset bit 5 flag = flag And &HFFFFFFEF ' Are allowed to write in the page VirtualProtect ByVal ptr, 4, PAGE_READWRITE, old ' Write changet flag GetMem4 flag, ByVal ptr + &H28 ' Restoring the memory attributes VirtualProtect ByVal ptr, 4, old, 0 End If count = count - 1 ptr = ptr + size Loop End Sub
Теперь, если попробовать запустить эту процедуру перед передачей хидера в VBDllGetClassObject, то будет запускаться процедура, определенная нами. Впрочем многопоточность уже будет работать, но это не удобно, т.к. отсутствует механизм передачи параметра в поток как это реализовано в CreateThread. Для того чтобы сделать полный аналог CreateThread я решил создать аналогичную функцию, которая будет проводить все инициализации и после выполнять вызов переданной функции потока вместе с параметром. Для того чтобы была возможность передать параметр в Sub Main, я использовал локальное хранилище потока (TLS). Мы выделяем индекс для TLS. После выделения индекса мы сможем задавать значение этого индекса, специфичное для каждого потока. В общем идея такова, создаем новый поток, где стартовой функцией будет специальная функция ThreadProc, в параметр которой передаем структуру из двух полей - адреса пользовательской функции и адреса параметра. В этой процедуре мы будем инициализировать рантайм для нового потока и сохранять в TLS переданный параметр. В качестве процедуры Main создадим бинарный код, который будет доставать данные из TLS, формировать стек и прыгать на пользовательскую функцию. В итоге получился такой модуль: modMultiThreading.bas Код (Visual Basic): ' modMultiThreading.bas - The module provides support for multi-threading. ' © Кривоус Анатолий Анатольевич (The trick), 2015 Option Explicit Private Type uuid data1 As Long data2 As Integer data3 As Integer data4(7) As Byte End Type Private Type threadData lpParameter As Long lpAddress As Long End Type Private tlsIndex As Long ' Index of the item in the TLS. There will be data specific to the thread. Private lpVBHeader As Long ' Pointer to VBHeader structure. Private hModule As Long ' Base address. Private lpAsm As Long ' Pointer to a binary code. ' // Create a new thread Public Function vbCreateThread(ByVal lpThreadAttributes As Long, _ ByVal dwStackSize As Long, _ ByVal lpStartAddress As Long, _ ByVal lpParameter As Long, _ ByVal dwCreationFlags As Long, _ lpThreadId As Long) As Long Dim InIDE As Boolean Debug.Assert MakeTrue(InIDE) If InIDE Then Dim ret As Long ret = MsgBox("Multithreading not working in IDE." & vbNewLine & "Run it in the same thread?", vbQuestion Or vbYesNo) If ret = vbYes Then ' Run function in main thread ret = DispCallFunc(ByVal 0&, lpStartAddress, CC_STDCALL, vbEmpty, 1, vbLong, VarPtr(CVar(lpParameter)), CVar(0)) If ret Then Err.Raise ret End If End If Exit Function End If ' Alloc new index from thread local storage If tlsIndex = 0 Then tlsIndex = TlsAlloc() If tlsIndex = 0 Then Exit Function End If ' Get module handle If hModule = 0 Then hModule = GetModuleHandle(ByVal 0&) End If ' Create assembler code If lpAsm = 0 Then lpAsm = CreateAsm() If lpAsm = 0 Then Exit Function End If ' Get pointer to VBHeader and modify If lpVBHeader = 0 Then lpVBHeader = GetVBHeader() If lpVBHeader = 0 Then Exit Function ModifyVBHeader lpAsm End If Dim lpThreadData As Long Dim tmpData As threadData ' Alloc thread-specific memory for threadData structure lpThreadData = HeapAlloc(GetProcessHeap(), 0, Len(tmpData)) If lpThreadData = 0 Then Exit Function ' Set parameters tmpData.lpAddress = lpStartAddress tmpData.lpParameter = lpParameter ' Copy parameters to thread-specific memory GetMem8 tmpData, ByVal lpThreadData ' Create thread vbCreateThread = CreateThread(ByVal lpThreadAttributes, _ dwStackSize, _ AddressOf ThreadProc, _ ByVal lpThreadData, _ dwCreationFlags, _ lpThreadId) End Function ' // Initialize runtime for new thread and run procedure Private Function ThreadProc(lpParameter As threadData) As Long Dim iid As uuid Dim clsid As uuid Dim lpNewHdr As Long Dim hHeap As Long ' Initialize COM vbCoInitialize ByVal 0& ' IID_IUnknown iid.data4(0) = &HC0: iid.data4(7) = &H46 ' Store parameter to thread local storage TlsSetValue tlsIndex, lpParameter ' Create the copy of VBHeader hHeap = GetProcessHeap() lpNewHdr = HeapAlloc(hHeap, 0, &H6A) CopyMemory ByVal lpNewHdr, ByVal lpVBHeader, &H6A ' Adjust offsets Dim names() As Long Dim diff As Long Dim Index As Long ReDim names(3) diff = lpNewHdr - lpVBHeader CopyMemory names(0), ByVal lpVBHeader + &H58, &H10 For Index = 0 To 3 names(Index) = names(Index) - diff Next CopyMemory ByVal lpNewHdr + &H58, names(0), &H10 ' This line calls the binary code that runs the asm function. VBDllGetClassObject VarPtr(hModule), 0, lpNewHdr, clsid, iid, 0 ' Free memeory HeapFree hHeap, 0, ByVal lpNewHdr HeapFree hHeap, 0, lpParameter End Function ' // Get VBHeader structure Private Function GetVBHeader() As Long Dim ptr As Long ' Get e_lfanew GetMem4 ByVal hModule + &H3C, ptr ' Get AddressOfEntryPoint GetMem4 ByVal ptr + &H28 + hModule, ptr ' Get VBHeader GetMem4 ByVal ptr + hModule + 1, GetVBHeader End Function ' // Modify VBHeader to replace Sub Main Private Sub ModifyVBHeader(ByVal newAddress As Long) Dim ptr As Long Dim old As Long Dim flag As Long Dim count As Long Dim size As Long ptr = lpVBHeader + &H2C ' Are allowed to write in the page VirtualProtect ByVal ptr, 4, PAGE_READWRITE, old ' Set a new address of Sub Main GetMem4 newAddress, ByVal ptr VirtualProtect ByVal ptr, 4, old, 0 ' Remove startup form GetMem4 ByVal lpVBHeader + &H4C, ptr ' Get forms count GetMem2 ByVal lpVBHeader + &H44, count Do While count > 0 ' Get structure size GetMem4 ByVal ptr, size ' Get flag (unknown5) from current form GetMem4 ByVal ptr + &H28, flag ' When set, bit 5, If flag And &H10 Then ' Unset bit 5 flag = flag And &HFFFFFFEF ' Are allowed to write in the page VirtualProtect ByVal ptr, 4, PAGE_READWRITE, old ' Write changet flag GetMem4 flag, ByVal ptr + &H28 ' Restoring the memory attributes VirtualProtect ByVal ptr, 4, old, 0 End If count = count - 1 ptr = ptr + size Loop End Sub ' // Create binary code. Private Function CreateAsm() As Long Dim hMod As Long Dim lpProc As Long Dim ptr As Long hMod = GetModuleHandle(ByVal StrPtr("kernel32")) lpProc = GetProcAddress(hMod, "TlsGetValue") If lpProc = 0 Then Exit Function ptr = VirtualAlloc(ByVal 0&, &HF, MEM_RESERVE Or MEM_COMMIT, PAGE_EXECUTE_READWRITE) If ptr = 0 Then Exit Function ' push tlsIndex ' call TLSGetValue ' pop ecx ' push DWORD [eax] ' push ecx ' jmp DWORD [eax + 4] GetMem4 &H68, ByVal ptr + &H0: GetMem4 &HE800, ByVal ptr + &H4 GetMem4 &HFF590000, ByVal ptr + &H8: GetMem4 &H60FF5130, ByVal ptr + &HC GetMem4 &H4, ByVal ptr + &H10: GetMem4 tlsIndex, ByVal ptr + 1 GetMem4 lpProc - ptr - 10, ByVal ptr + 6 CreateAsm = ptr End Function Private Function MakeTrue(value As Boolean) As Boolean MakeTrue = True: value = True End Function Все API декларации я сделал в отдельной библиотеке типов - EXEInitialize.tlb. Пока найден один недостаток - не работают формы с приватными контролами, если разберусь в чем причина - исправлю. Работает только в скомпилированном варианте. В архиве содержится несколько тестов. 1-й: создание формы в новом потоке, с возможностью блокировки ввода посредством длинного цикла. 2-й: обработка событий от объекта, метод которого вызван в другом потоке. Сразу скажу так делать нельзя и неправильно, т.к. передавать между потоками ссылку без маршаллинга опасно и может привести к глюкам, к тому же обработка события выполняется в другом потоке. Этот пример я оставил в качестве демонстрации работы многопоточности, а не для использования в повседневных задачах. 3-й: демонстрация изменения значения общей переменной в одном потоке и считывание его из другого. В IDE запуск осуществляется в главном потоке по желанию. Добавлена нативная DLL которая экспортирует vbCreateThread. Всем удачи!