1. Если вы только начинаете программировать на ассемблере и не знаете с чего начать, тогда попробуйте среду разработки ASM Visual IDE
    (c) на правах рекламы
    Скрыть объявление

Многопоточность на VB6

Тема в разделе "VB", создана пользователем Thetrik, 11 дек 2016.

  1. Thetrik

    Thetrik UA6527P

    Публикаций:
    0
    Регистрация:
    25 июл 2011
    Сообщения:
    669
    Часть 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):
    1. ' Класс MultithreadDownloader - класс загрузчика
    2. ' © Кривоус Анатолий Анатольевич (The trick), 2014
    3. Option Explicit
    4. Public Enum ErrorCodes
    5.     OK
    6.     NOT_INITIALIZE
    7.     ERROR_CREATING_DST_FILE
    8. End Enum
    9. Private Declare Function InternetCloseHandle Lib "wininet" (ByRef hInternet As Long) As Boolean
    10. 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
    11. 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
    12. Private Declare Function InternetReadFile Lib "wininet" (ByVal hFile As Long, lpBuffer As Any, ByVal dwNumberOfBytesToRead As Long, ByRef lpdwNumberOfBytesRead As Long) As Integer
    13. 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
    14. 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
    15. 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
    16. Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
    17. Private Const INTERNET_OPEN_TYPE_PRECONFIG  As Long = 0
    18. Private Const INTERNET_FLAG_RELOAD          As Long = &H80000000
    19. Private Const HTTP_QUERY_CONTENT_LENGTH     As Long = 5
    20. Private Const HTTP_QUERY_FLAG_NUMBER        As Long = &H20000000
    21. Private Const CREATE_ALWAYS                 As Long = 2
    22. Private Const FILE_ATTRIBUTE_NORMAL         As Long = &H80
    23. Private Const INVALID_HANDLE_VALUE          As Long = -1
    24. Private Const GENERIC_WRITE                 As Long = &H40000000
    25. Public Event Complete()
    26. Public Event Error(ByVal Code As Long)
    27. Public Event Progress(ByVal Size As Currency, ByVal TotalSize As Currency, cancel As Boolean)
    28. Private mBufferSize As Long
    29. Private mError      As ErrorCodes
    30. Dim hInternet   As Long
    31. Public Property Get ErrorCode() As ErrorCodes
    32.     ErrorCode = mError
    33. End Property
    34. Public Property Get BufferSize() As Long
    35.     BufferSize = mBufferSize
    36. End Property
    37. Public Property Let BufferSize(ByVal Value As Long)
    38.     If Value > &H1000000 Or Value < &H400 Then Err.Raise vbObjectError, "MultithreadDownloader", "Wrong buffer size": Exit Property
    39.     mBufferSize = Value
    40. End Property
    41. Public Sub Download(URL As String, Filename As String)
    42.     Dim hFile   As Long
    43.     Dim hDst    As Long
    44.     Dim fSize   As Currency
    45.     Dim total   As Long
    46.     Dim prgSize As Currency
    47.     Dim cancel  As Boolean
    48.     Dim buf()   As Byte
    49.    
    50.     If hInternet = 0 Then mError = NOT_INITIALIZE: RaiseEvent Error(mError): Exit Sub
    51.     hFile = InternetOpenUrl(hInternet, StrPtr(URL), 0, 0, INTERNET_FLAG_RELOAD, 0)
    52.    
    53.     If hFile = 0 Then mError = Err.LastDllError: RaiseEvent Error(mError): Exit Sub
    54.    
    55.     If HttpQueryInfo(hFile, HTTP_QUERY_CONTENT_LENGTH Or HTTP_QUERY_FLAG_NUMBER, fSize, 8, 0) Then
    56.         hDst = CreateFile(StrPtr(Filename), GENERIC_WRITE, 0, ByVal 0&, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
    57.         If hDst = INVALID_HANDLE_VALUE Then mError = ERROR_CREATING_DST_FILE: RaiseEvent Error(mError): Exit Sub
    58.         ReDim buf(mBufferSize - 1)
    59.         Do
    60.             If InternetReadFile(hFile, buf(0), mBufferSize, total) = 0 Then
    61.                 mError = Err.LastDllError
    62.                 RaiseEvent Error(mError)
    63.                 InternetCloseHandle hFile
    64.                 Exit Sub
    65.             End If
    66.             WriteFile hDst, buf(0), total, 0, ByVal 0&
    67.             prgSize = prgSize + CCur(total) / 10000@
    68.             RaiseEvent Progress(prgSize, fSize, cancel)
    69.         Loop While (total = mBufferSize) And Not cancel
    70.         CloseHandle hDst
    71.         RaiseEvent Complete
    72.     Else
    73.         mError = Err.LastDllError
    74.         RaiseEvent Error(mError)
    75.     End If
    76.     InternetCloseHandle hFile
    77.     mError = OK
    78. End Sub
    79. Private Sub Class_Initialize()
    80.     ' Инициализация WinInet
    81.     hInternet = InternetOpen(StrPtr(App.ProductName), INTERNET_OPEN_TYPE_PRECONFIG, 0, 0, 0)
    82.     mBufferSize = &H10000
    83. End Sub
    84. Private Sub Class_Terminate()
    85.     ' Деинициализация
    86.     If hInternet Then InternetCloseHandle hInternet
    87. End Sub
    88.  
    Код в принципе простой, если прочитать описание API функций. При вызове метода Download, начинает выполнятся загрузка, периодически (зависит от размера буфера) генерируется событие Progress. При ошибке генерируется событие Error, и при окончании Complete. BufferSize - задает размер буфера, при заполнении которого генерируется событие. Код демонстрационный и содержит недочеты.
     
  2. Thetrik

    Thetrik UA6527P

    Публикаций:
    0
    Регистрация:
    25 июл 2011
    Сообщения:
    669
    Класс я назвал MultithreadDownloader, а библиотеку MTDownloader, соответственно ProgID этого объекта MTDownloader.MultithreadDownloader. После компиляции получаем описание интерфейсов через OleView, PEExplorer и т.п. В моем примере CLSID = {20FAEF52-0D1D-444B-BBAE-21240219905B}, IID = {DF3BDB52-3380-4B78-B691-4138300DD304}. Также я поставил галочку RemoteServerFiles чтобы получить на выходе библиотеку типов для нашей DLL, и будем подключать ее вместо DLL для гарантированного запуска приложения.
    Код клиентского приложения:
    Форма -
    Код (Visual Basic):
    1. ' frmDownloader.frm - форма загрузчика
    2. ' © Кривоус Анатолий Анатольевич (The trick), 2014
    3. Option Explicit
    4. ' Объявляем объектную переменную с подпиской на события
    5. Dim WithEvents Downloader As MTDownloader.MultithreadDownloader
    6. Dim param   As ThreadData   ' Данные потока
    7. Dim tid     As Long         ' ИД потока
    8. Dim hThread As Long         ' Описатель потока
    9. Dim mCancel As Boolean      ' Если отмена закачки
    10. Dim mActive As Boolean      ' Если активна закачка
    11. ' // Отмена
    12. Private Sub cmdCancel_Click()
    13.     mCancel = True
    14. End Sub
    15. ' // Скачать файл
    16. Private Sub cmdDownload_Click()
    17.     Dim ptr As Long
    18.     ' Проверяем, идет ли уже вызов
    19.     If WaitForSingleObject(param.hEvent, 0) = WAIT_OBJECT_0 Then
    20.         ' Упаковываем параметры
    21.         ptr = MT_DOWNLOAD_packParam(txtURL.Text, txtPath.Text)
    22.         If ptr Then
    23.             mCancel = False
    24.             mActive = True
    25.             ' Очистка прогрессбара
    26.             picProgress.Cls
    27.             ' Отправляем запрос на асинхронный вызов метода в другом потоке
    28.             PostThreadMessage tid, WM_MT_DOWNLOAD, 0, ptr
    29.         Else
    30.             MsgBox "Не удалось упаковать параметры", vbCritical
    31.         End If
    32.     Else
    33.         MsgBox "Скачивание еще идет", vbInformation
    34.     End If
    35. End Sub
    36. ' // Окончание загрузки
    37. Private Sub Downloader_Complete()
    38.     mActive = False
    39.     MsgBox "Загрузка завершена"
    40. End Sub
    41. ' // Ошибка загрузки
    42. Private Sub Downloader_Error(ByVal Code As Long)
    43.     mActive = False
    44.     MsgBox "Ошибка"
    45. End Sub
    46. ' // Прогресс
    47. Private Sub Downloader_Progress(ByVal Size As Currency, ByVal TotalSize As Currency, cancel As Boolean)
    48.     Dim sVal    As String
    49.     Dim wTxt    As Single
    50.    
    51.     cancel = mCancel
    52.     picProgress.Cls
    53.     picProgress.Line (0, 0)-(Size / TotalSize, 1), vbRed, BF
    54.    
    55.     sVal = Format(Size / TotalSize, "##0%")
    56.     wTxt = picProgress.TextWidth(sVal)
    57.     picProgress.CurrentX = (1 - wTxt) / 2
    58.     picProgress.CurrentY = 0
    59.     picProgress.Print sVal
    60.     picProgress.Refresh
    61.    
    62. End Sub
    63. Private Sub Form_Initialize()
    64.     InitCommonControlsEx 3435973.8623@
    65. End Sub
    66. Private Sub Form_Load()
    67.     Dim iid As UUID
    68.     Dim obj As MTDownloader.MultithreadDownloader
    69.     ' Удаляем вылет Declared функций
    70.     RemoveLastDllError
    71.     ' Создаем синхронизирующий объект
    72.     param.hEvent = CreateEvent(ByVal 0&, 1, 0, 0)
    73.     ' Создаем поток
    74.     hThread = CreateThread(ByVal 0&, 0, AddressOf ThreadProc, ByVal VarPtr(param), 0, tid)
    75.     If hThread = 0 Then
    76.         MsgBox "Не удалось создать поток", vbCritical
    77.         End
    78.     End If
    79.     ' Ждем инициализацию объекта
    80.     WaitForSingleObject param.hEvent, INFINITE
    81.     ' Если успешно
    82.     If param.IStream Then
    83.         ' Преобразуем интерфейс в бинарную форму
    84.         IIDFromString StrPtr(IID_MultithreadDownloader), iid
    85.         ' Получаем отмаршаленный указатель на объект
    86.         CoGetInterfaceAndReleaseStream param.IStream, iid, obj
    87.         Set Downloader = obj
    88.     Else
    89.         MsgBox "Не удалось создать объект", vbCritical
    90.         End
    91.     End If
    92.     ' Проверяем корректность инициализации объекта
    93.     If Downloader.ErrorCode = NOT_INITIALIZE Then
    94.         MsgBox "Объект не инициализирован", vbCritical
    95.         End
    96.     End If
    97.     ' Задаем размер буфера в 100 кб
    98.     Downloader.BufferSize = &H10000
    99. End Sub
    100. Private Sub Form_Unload(cancel As Integer)
    101.     If mActive Then
    102.         MsgBox "Идет загрузка"
    103.         cancel = True
    104.         Exit Sub
    105.     End If
    106.     If tid Then
    107.         ' Освобождаем объект
    108.         Set Downloader = Nothing
    109.         ' Отправляем запрос на завершение потока
    110.         PostThreadMessage tid, WM_QUIT, 0, 0
    111.         ' Ждем завершение, т.к. поток ссылается на param
    112.         WaitForSingleObject hThread, INFINITE
    113.         ' Закрываем описатели
    114.         CloseHandle hThread
    115.         CloseHandle param.hEvent
    116.     End If
    117. End Sub
    118.  
     
  3. Thetrik

    Thetrik UA6527P

    Публикаций:
    0
    Регистрация:
    25 июл 2011
    Сообщения:
    669
    Модуль:
    Код (Visual Basic):
    1. ' modMain.bas - главный модуль загрузчика
    2. ' © Кривоус Анатолий Анатольевич (The trick), 2014
    3. Option Explicit
    4. Public Type POINTAPI
    5.     x   As Long
    6.     y   As Long
    7. End Type
    8. Public Type msg
    9.     hwnd    As Long
    10.     message As Long
    11.     wParam  As Long
    12.     lParam  As Long
    13.     time    As Long
    14.     pt      As POINTAPI
    15. End Type
    16. Public Type UUID
    17.     Data1           As Long
    18.     Data2           As Integer
    19.     Data3           As Integer
    20.     Data4(0 To 7)   As Byte
    21. End Type
    22. 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
    23. Public Declare Function TranslateMessage Lib "user32" (lpMsg As msg) As Long
    24. Public Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageW" (lpMsg As msg) As Long
    25. 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
    26. Public Declare Function GetMem1 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
    27. Public Declare Function GetMem4 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
    28. Public Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
    29. Public Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As Long) As Long
    30. Public Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
    31. 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
    32. Public Declare Function CoInitialize Lib "ole32" (pvReserved As Any) As Long
    33. Public Declare Function CoUninitialize Lib "ole32" () As Long
    34. Public Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Long, pclsid As UUID) As Long
    35. Public Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, lpiid As UUID) As Long
    36. 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
    37. Public Declare Function CoMarshalInterThreadInterfaceInStream Lib "ole32.dll" (riid As UUID, ByVal pUnk As IUnknown, ppStm As Long) As Long
    38. Public Declare Function CoGetInterfaceAndReleaseStream Lib "ole32.dll" (ByVal pStm As Long, riid As UUID, pUnk As Any) As Long
    39. Public Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
    40. Public Declare Function SetEvent Lib "kernel32" (ByVal hEvent As Long) As Long
    41. Public Declare Function ResetEvent Lib "kernel32" (ByVal hEvent As Long) As Long
    42. 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
    43. Public Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyW" (lpString1 As Any, lpString2 As Any) As Long
    44. Public Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (lpString As Any) As Long
    45. Public Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
    46. Public Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
    47. Public Declare Function GetProcessHeap Lib "kernel32" () As Long
    48. Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
    49. Public Declare Function InitCommonControlsEx Lib "comctl32" (icc As Any) As Long
    50. Public Const CLSCTX_INPROC_SERVER           As Long = 1
    51. Public Const PAGE_EXECUTE_READWRITE         As Long = &H40&
    52. Public Const CLSID_MultithreadDownloader    As String = "{20FAEF52-0D1D-444B-BBAE-21240219905B}"
    53. Public Const IID_MultithreadDownloader      As String = "{DF3BDB52-3380-4B78-B691-4138300DD304}"
    54. Public Const WM_APP                         As Long = &H8000&
    55. Public Const WM_QUIT                        As Long = &H12
    56. Public Const WM_MT_DOWNLOAD                 As Long = WM_APP    ' Сообщение потоку чтобы вызвать метод
    57. Public Const INFINITE                       As Long = -1&
    58. Public Const WAIT_OBJECT_0                  As Long = 0
    59. Public Type ThreadData
    60.     hEvent  As Long     ' Объект синхронизации
    61.     IStream As Long     ' Объект потока, получающий ссылку на отмаршалленый объект MultithreadDownloader
    62. End Type
    63. ' // Удаляем вылеты Declare функций, жертвуя Err.LastDllError
    64. ' // Если использовать tlb, то не нужна.
    65. Public Sub RemoveLastDllError()
    66.     Dim hMod    As Long
    67.     Dim lpProc  As Long
    68.     ' Получаем адрес функции __vbaSetSystemError
    69.     hMod = GetModuleHandle(StrPtr("msvbvm60"))
    70.     lpProc = GetProcAddress(hMod, "__vbaSetSystemError")
    71.     ' Делаем ret
    72.     VirtualProtect lpProc, 1, PAGE_EXECUTE_READWRITE, 0
    73.     GetMem1 &HC3, ByVal lpProc
    74. End Sub
    75. ' // Функция потока
    76. Public Function ThreadProc(value As ThreadData) As Long
    77.     Dim clsid   As UUID
    78.     Dim iid     As UUID
    79.     Dim obj     As MTDownloader.MultithreadDownloader
    80.     ' Инициализируем COM
    81.     CoInitialize ByVal 0&
    82.     ' Инициализируем CLSID и IID для создания и управления объектом
    83.     IIDFromString StrPtr(IID_MultithreadDownloader), iid
    84.     CLSIDFromString StrPtr(CLSID_MultithreadDownloader), clsid
    85.     ' Создаем объект MTDownloader.MultithreadDownloader
    86.     If CoCreateInstance(clsid, 0, CLSCTX_INPROC_SERVER, iid, obj) = 0 Then
    87.         ' Маршаллинг для отлова событий в другом потоке
    88.         CoMarshalInterThreadInterfaceInStream iid, obj, value.IStream
    89.         ' Объект инициализирован
    90.         SetEvent value.hEvent
    91.     Else
    92.         ' Объект не инициализирован
    93.         SetEvent value.hEvent
    94.         ' Деинициализация
    95.         CoUninitialize
    96.         ' Выход
    97.         Exit Function
    98.     End If
    99.    
    100.     Dim msg As msg
    101.     Dim ret As Long
    102.     Dim URL As String
    103.     Dim fle As String
    104.    
    105.     ' Цикл обработки сообщений в новом потоке
    106.     Do
    107.         ret = GetMessage(msg, 0, 0, 0)
    108.         If ret = -1 Or ret = 0 Then Exit Do
    109.         ' Проверяем сообщения
    110.         Select Case msg.message
    111.         Case WM_MT_DOWNLOAD
    112.             ' Получаем запакованные параметры, они лежат последовательно
    113.             ret = lstrlen(ByVal msg.lParam)
    114.             URL = Space(ret)
    115.             lstrcpy ByVal StrPtr(URL), ByVal msg.lParam
    116.             ret = lstrlen(ByVal msg.lParam + (ret + 1) * 2)
    117.             fle = Space(ret)
    118.             lstrcpy ByVal StrPtr(fle), ByVal msg.lParam + LenB(URL) + 2
    119.             ' Сбрасываем событие, чтобы нельзя было вызвать метод еще раз пока не отработает предыдущий вызов
    120.             ResetEvent value.hEvent
    121.             ' Вызываем метод
    122.             obj.Download URL, fle
    123.             ' Устанавливаем событие - объект свободен
    124.             SetEvent value.hEvent
    125.             ' Очищаем параметры
    126.             HeapFree GetProcessHeap(), 0, ByVal msg.lParam
    127.         Case Else
    128.             TranslateMessage msg
    129.             DispatchMessage msg
    130.         End Select
    131.     Loop
    132.    
    133.     ' Удаляем объекты
    134.     Set obj = Nothing
    135.     ' Деинициализация
    136.     CoUninitialize
    137.    
    138. End Function
    139. ' // Упаковка параметров последовательно
    140. Public Function MT_DOWNLOAD_packParam(URL As String, fileName As String) As Long
    141.     MT_DOWNLOAD_packParam = HeapAlloc(GetProcessHeap(), 0, LenB(URL) + LenB(fileName) + 4)
    142.     If MT_DOWNLOAD_packParam Then
    143.         lstrcpy ByVal MT_DOWNLOAD_packParam, ByVal StrPtr(URL)
    144.         lstrcpy ByVal MT_DOWNLOAD_packParam + LenB(URL) + 2, ByVal StrPtr(fileName)
    145.     End If
    146. End Function
    147.  
    Разберем подробно код. При загрузке формы (Form_Load), мы пропатчиваем рантайм для исключения ошибки использования Declared функций в неинициализированном потоке (RemoveLastDllError). Принцип я описал выше. Если мы создаем объект в другом потоке, то нам нужно как-то проверить в основном потоке, создался ли объект. Для этого я использовал простейший синхронизирующий объект - событие с ручным сбросом. Иницииализируем его в сброшенном состоянии. Далее создаем поток в функции ThreadProc, в качестве параметра передаем структуру из синхронизирующего события и ссылки на объект потока (Stream), который нужен для маршалинга. В этом объекте веренется ссылка на отмаршаленый указатель на объект. При успехе ждем срабатывания события (WaitForSingleObject). На этом основной поток приостанавливает свое выполнение пока мы не установим событие hEvent. В новом потоке сначала инициализируем COM (CoInitialize), переводим CLSID и IID в двоичную форму, создаем объект (CoCreateInstance). Здесь, если не нужна обработка ошибок, то можно использовать
    Код (Visual Basic):
    1. CreateObject("MTDownloader.MultithreadDownloader")
    В данном коде для создания объекта я использовал CoCreateInstance, т.к. до создания первого объекта мы не можем включить обработку ошибок (причина описана выше), после создания первого объекта далее можно создавать через VB-шный CreateObject. Если обработка ошибок не нужна, то можно сразу использовать CreateObject.
     
  4. Thetrik

    Thetrik UA6527P

    Публикаций:
    0
    Регистрация:
    25 июл 2011
    Сообщения:
    669
    При успехе выполняем маршалинг, для этого вызываем функцию 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, достаточно положить ее в ту же папку благодаря манифесту. В итоге имеем многопоточное приложение которое работает на любой машине без запроса админских прав.
    [​IMG]
     

    Вложения:

  5. Thetrik

    Thetrik UA6527P

    Публикаций:
    0
    Регистрация:
    25 июл 2011
    Сообщения:
    669
    Часть 2 - создание Native DLL и вызов экспортируемой функции в другом потоке.
    Теперь я расскажу о еще одном методе написания многопоточных программ на VB6, а именно создание потока в Native DLL. В принципе здесь нет ничего сложного, передаем в CreateThread адрес экспортируемой функции и она будет исполнена в другом потоке. Все бы хорошо, но стандартными, документированными возможностями VB6 не позволяет создавать нативные DLL. Но не все так плохо, есть несколько приемов, с помощью которых можно создать нативную DLL, начиная от подмены линкера и заканчивая недокументированными секциями в vbp-файле. Как раз последний способ мы и будем использовать для создания DLL. Для начала нужно решить, что нам вообще нужно от DLL, чтобы можно было применить многопоточность. В прошлый раз я делал загрузку файла, сейчас я решил уделить внимание вычислениям. Т.е. в новом потоке у нас будут производится вычисления, а основной поток будет обслуживать GUI. Для теста я разработал DLL для работы с графикой, а если быть точнее то в DLL будут функции, которые преобразуют растровое изображение - накладывают различные эффекты.
    Как-то давно, когда я начинал программировать, и изучал фильтры на основе свертки, то мне очень не нравилась "тормознутость" этих методов. Теперь есть возможность засунуть вычисления в другой поток без блокировки главного. Я создал 10 функций, которые будут экспортироваться:
    1. Brightness - Яркость
    2. Contrast - Контрастность
    3. Saturation - Насыщенность
    4. GaussianBlur - Размытие
    5. EdgeDetect - Выделение контуров
    6. Sharpen - Резкость
    7. Emboss - Тиснение
    8. Minimum - Минимум
    9. Maximum - Максимум
    10. 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):
    1. Public Function DllMain(ByVal hInstDLL As Long, ByVal fdwReason As Long, ByVal lpvReserved As Long) As Long
    2.  
    3. End Function
    В hInstDLL - передается базовый адрес загрузки модуля (он же hInstance, hModule), в fdwReason передается значение указывающее причину вызова этой функции. Существует 4 случая вызова этой функции, когда DLL загружается в адресное пространство процесса (DLL_PROCESS_ATTACH), когда создается новый поток в процессе (DLL_THREAD_ATTACH) и соответственно два парных противоположных случая при корректном завершении потока (DLL_THREAD_DETACH) и выгрузке DLL из памяти (DLL_PROCESS_DETACH), также корректном. lpReserved - нам не важен. Теперь при загрузке DLL будет вызываться наша функция и мы сможем делать инициализацию. С этим понятно.
     
  6. Thetrik

    Thetrik UA6527P

    Публикаций:
    0
    Регистрация:
    25 июл 2011
    Сообщения:
    669
    Теперь представим ситуацию, что DLL загрузилась в АП процесса, а процесс создал поток и оба вызвали функцию Foo, что будет? Какое значение будет иметь переменная Temp после окончания потоков?
    Код (Visual Basic):
    1. ' Код DLL
    2. Dim Temp As Long
    3. Public Sub foo()
    4.     Temp = App.ThreadID
    5. End Sub
    6.  
    Все зависит от того, какой поток последним запишет значение в переменную 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 из рантайма, передавая первыми двумя параметрами два указателя:
    [​IMG]
    Итак, чтобы начать инициализацию нужно вызвать из нашей точки входа UserDllMain из VB6, но нужно достать 2 параметра. Пока мы этого делать не будем, т.к. одного вызова UserDllMain недостаточно, иначе можно было бы не заморачиваться а оставить как есть, она вызывается по умолчанию. Инициализация потока выполняется при создании объекта из ActiveX DLL. Для того чтобы создать объект нужно вызвать функцию DllGetClassObject из DLL. Давайте посмотрим как выглядит эта функция внутри, а заодно и другие экспортируемые функции:
    [​IMG]
    Функция 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 не должно быть обращений к модульным переменным.
     
  7. Thetrik

    Thetrik UA6527P

    Публикаций:
    0
    Регистрация:
    25 июл 2011
    Сообщения:
    669
    Для обеих моделей я создал 2 модуля:
    Для single threaded:
    Код (Visual Basic):
    1. ' modMainDLL.bas  - инициализация DLL (Single thread)
    2. ' © Кривоус Анатолий Анатольевич (The trick), 2014
    3. Option Explicit
    4. Private Type uuid
    5.     data1       As Long
    6.     data2       As Integer
    7.     data3       As Integer
    8.     data4(7)    As Byte
    9. End Type
    10. Public hInstance    As Long
    11. Private lpInst_     As Long
    12. Private lpUnk_      As Long
    13. Private lpVBHdr_    As Long
    14. ' Точка входа
    15. Public Function DllMain(ByVal hInstDll As Long, ByVal fdwReason As Long, ByVal lpvReserved As Long) As Long
    16.     Dim lpProc      As Long
    17.     Dim lpInst      As Long
    18.     Dim lpUnk       As Long
    19.     Dim lpVBHdr     As Long
    20.  
    21.     ' При создании процесса инициализируем адреса нужных переменных
    22.     If fdwReason = DLL_PROCESS_ATTACH Then
    23.         ' Получаем нужные нам данные, VBHeader, и два указателя необходимых для инициализации
    24.         lpProc = GetProcAddress(hInstDll, "DllGetClassObject")
    25.         If lpProc = 0 Then Exit Function
    26.         GetMem4 ByVal lpProc + 2, lpVBHdr
    27.         GetMem4 ByVal lpProc + 7, lpUnk
    28.         GetMem4 ByVal lpProc + 12, lpInst
    29.         DllMain = InitRuntime(lpInst, lpUnk, lpVBHdr, hInstDll, fdwReason, lpvReserved)
    30.         lpInst_ = lpInst: lpUnk_ = lpUnk: lpVBHdr_ = lpVBHdr: hInstance = hInstDll
    31.     ElseIf fdwReason = DLL_THREAD_ATTACH Then
    32.         DllMain = InitRuntime(lpInst_, lpUnk_, lpVBHdr_, hInstDll, fdwReason, lpvReserved)
    33.     Else
    34.         vbCoUninitialize
    35.         DllMain = UserDllMain(lpInst_, lpUnk_, hInstDll, fdwReason, ByVal lpvReserved)
    36.     End If
    37.  
    38. End Function
    39. Private Function InitRuntime(ByVal lpInst As Long, ByVal lpUnk As Long, ByVal lpVBHdr As Long, ByVal hInstDll As Long, _
    40.                              ByVal fdwReason As Long, ByVal lpvReserved As Long) As Long
    41.     Dim iid     As uuid
    42.     Dim clsid   As uuid
    43.  
    44.     InitRuntime = UserDllMain(lpInst, lpUnk, hInstDll, fdwReason, ByVal lpvReserved)
    45.     If InitRuntime Then
    46.         vbCoInitialize ByVal 0&
    47.         iid.data4(0) = &HC0: iid.data4(7) = &H46                    ' IUnknown
    48.         VBDllGetClassObject lpInst, lpUnk, lpVBHdr, clsid, iid, 0   ' Инициализация потока
    49.     End If
    50. End Function
    Для apartment threaded:
    Код (Visual Basic):
    1. ' modMainDLL.bas  - инициализация DLL (Apartment threaded)
    2. ' © Кривоус Анатолий Анатольевич (The trick), 2014
    3. Option Explicit
    4. Private Type uuid
    5.     data1       As Long
    6.     data2       As Integer
    7.     data3       As Integer
    8.     data4(7)    As Byte
    9. End Type
    10. Public hInstance    As Long
    11. Private lpInst_     As Long
    12. Private lpUnk_      As Long
    13. Private lpVBHdr_    As Long
    14. ' Точка входа, здесь не должно быть обращения к внешним переменным, т.е. public, private, static
    15. Public Function DllMain(ByVal hInstDLL As Long, ByVal fdwReason As Long, ByVal lpvReserved As Long) As Long
    16.     Dim iid         As uuid
    17.     Dim clsid       As uuid
    18.     Dim lpInst     As Long
    19.     Dim lpUnk      As Long
    20.     Dim lpVBHdr    As Long
    21.     Dim lpProc  As Long
    22.  
    23.     ' При создании процесса или потока
    24.     If fdwReason = DLL_PROCESS_ATTACH Or fdwReason = DLL_THREAD_ATTACH Then
    25.         ' Получаем нужные нам данные, VBHeader, и два указателя необходимых для инициализаци
    26.         ' Каждый поток содержит свои данные (публичные, статичные переменные и т.д.)
    27.         lpProc = GetProcAddress(hInstDLL, "DllGetClassObject")
    28.         If lpProc = 0 Then Exit Function
    29.         GetMem4 ByVal lpProc + 2, lpVBHdr
    30.         GetMem4 ByVal lpProc + 7, lpUnk
    31.         GetMem4 ByVal lpProc + 12, lpInst
    32.         ' Инициализация COM
    33.         vbCoInitialize ByVal 0&
    34.         ' Эта функция вызывается из ActiveX DLL
    35.         DllMain = UserDllMain(lpInst, lpUnk, hInstDLL, fdwReason, ByVal lpvReserved)
    36.         If DllMain = 0 Then Exit Function
    37.         iid.data4(0) = &HC0: iid.data4(7) = &H46                            ' IUnknown
    38.         VBDllGetClassObject lpInst, lpUnk, lpVBHdr, clsid, iid, 0           ' Инициализация потока
    39.         ' Тут глобальные и статичные переменные обнуляются, восстанавливаем их
    40.         SetPublicVariable lpInst, lpUnk, lpVBHdr, hInstDLL
    41.     Else
    42.         vbCoUninitialize
    43.         DllMain = DefMainDLL(hInstDLL, fdwReason, ByVal lpvReserved)
    44.     End If
    45. End Function
    46. Private Sub SetPublicVariable(ByVal lpInst As Long, ByVal lpUnk As Long, ByVal lpVBHdr As Long, ByVal hInstDLL As Long)
    47.     lpInst_ = lpInst: lpUnk_ = lpUnk: lpVBHdr_ = lpVBHdr: hInstance = hInstDLL
    48. End Sub
    49. Private Function DefMainDLL(ByVal hInstDLL As Long, ByVal fdwReason As Long, ByVal lpvReserved As Long) As Long
    50.     DefMainDLL = UserDllMain(lpInst_, lpUnk_, hInstDLL, fdwReason, ByVal lpvReserved)
    51. End Function
    52.  
    Итак, теперь мы умеем инициализировать рантайм и можем приступить к компиляции нативной DLL. В файл проекта добавляем вот эти строки позволяющие указать дополнительные ключи компилятора и линкера:
    Код (Text):
    1. [VBCompiler]
    2. LinkSwitches= /ENTRY:DllMain /EXPORT:Brightness /EXPORT:Contrast /EXPORT:Saturation /EXPORT:GaussianBlur /EXPORT:EdgeDetect /EXPORT:Sharpen /EXPORT:Emboss /EXPORT:Minimum /EXPORT:Maximum /EXPORT:FishEye
    3.  
    И настраиваем потоковую модель проекта в single threaded, также нужно в проект добавить класс, иначе проект не скомпилируется. По желанию можно также добавить функциональность ActiveX DLL, тогда можно с этой DLL работать и как с ActiveX, и как с обычной нативной импортируя функции.
     
  8. Thetrik

    Thetrik UA6527P

    Публикаций:
    0
    Регистрация:
    25 июл 2011
    Сообщения:
    669
    Для тестирования DLL была написана мини-программа:
    Код (Visual Basic):
    1. ' Демонстрация использования многопоточности в NativeDLL на примере графических эффектов
    2. ' © Кривоус Анатолий Анатольевич (The trick), 2014
    3. Option Explicit
    4. ' Структура, идентичная объявленной в DLL
    5. Private Type ThreadData
    6.     pix()       As Byte
    7.     value       As Single
    8.     percent     As Single
    9. End Type
    10. Private Type BITMAPINFOHEADER
    11.     biSize          As Long
    12.     biWidth         As Long
    13.     biHeight        As Long
    14.     biPlanes        As Integer
    15.     biBitCount      As Integer
    16.     biCompression   As Long
    17.     biSizeImage     As Long
    18.     biXPelsPerMeter As Long
    19.     biYPelsPerMeter As Long
    20.     biClrUsed       As Long
    21.     biClrImportant  As Long
    22. End Type
    23. Private Type BITMAPINFO
    24.     bmiHeader       As BITMAPINFOHEADER
    25.     bmiColors       As Long
    26. End Type
    27. Private Type OPENFILENAME
    28.     lStructSize         As Long
    29.     hwndOwner           As Long
    30.     hInstance           As Long
    31.     lpstrFilter         As Long
    32.     lpstrCustomFilter   As Long
    33.     nMaxCustFilter      As Long
    34.     nFilterIndex        As Long
    35.     lpstrFile           As Long
    36.     nMaxFile            As Long
    37.     lpstrFileTitle      As Long
    38.     nMaxFileTitle       As Long
    39.     lpstrInitialDir     As Long
    40.     lpstrTitle          As Long
    41.     Flags               As Long
    42.     nFileOffset         As Integer
    43.     nFileExtension      As Integer
    44.     lpstrDefExt         As Long
    45.     lCustData           As Long
    46.     lpfnHook            As Long
    47.     lpTemplateName      As Long
    48. End Type
    49. Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameW" (pOpenfilename As OPENFILENAME) As Long
    50. 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
    51. 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
    52. Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
    53. 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
    54. Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As Long) As Long
    55. Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
    56. Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
    57. Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
    58. Private Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, lpExitCode As Long) As Long
    59. Private Const STILL_ACTIVE  As Long = &H103&
    60. Private Const INFINITE      As Long = -1&
    61. Dim hLib    As Long         ' hInstance библиотеки
    62. Dim td      As ThreadData   ' Данные потока
    63. Dim hThread As Long         ' Описатель потока
    64. Dim pic     As StdPicture   ' Изображение
    65. Dim bi      As BITMAPINFO   ' Информация об изображении
    66. Dim quene   As Boolean      ' Флаг очереди
    67. ' // Нажатие на кнопку загрузки рисунка
    68. Private Sub cmdLoad_Click()
    69.     ' Загружаем
    70.     LoadImage
    71. End Sub
    72. ' // Загрузка формы
    73. Private Sub Form_Load()
    74.     ' Загружаем DLL
    75.     ChDir App.Path: ChDrive App.Path
    76.     hLib = LoadLibrary(StrPtr("..\GraphicsDLL\GraphicsDLL.dll"))
    77.     If hLib = 0 Then MsgBox "Неудалось загрузить DLL": End
    78.     ' Загружаем картинку по умолчанию
    79.     LoadImage "defpic.jpg"
    80. End Sub
    81. ' // Выгрузка формы
    82. Private Sub Form_Unload(cancel As Integer)
    83.     ' Если поток выполняется ждем завершения
    84.     If hThread Then WaitForSingleObject hThread, INFINITE
    85.     ' Выгружаем библиотеку
    86.     FreeLibrary hLib
    87. End Sub
    88. ' // Запускаем эффект
    89. Private Sub RunEffect()
    90.  
    91.     Select Case cboEffect.ListIndex
    92.     Case 0: picImage.PaintPicture pic, 0, 0                 ' Исходное изображение
    93.     Case 1: RunProcedure "Brightness", sldValue / 50 - 1    ' Яркость
    94.     Case 2: RunProcedure "Contrast", sldValue / 50          ' Контрастность
    95.     Case 3: RunProcedure "Saturation", sldValue / 100       ' Насыщенность
    96.     Case 4: RunProcedure "GaussianBlur", sldValue / 2       ' Размытие
    97.     Case 5: RunProcedure "EdgeDetect", sldValue / 2 + 1     ' Выделение контуров
    98.     Case 6: RunProcedure "Sharpen", sldValue / 3            ' Резкость
    99.     Case 7: RunProcedure "Emboss", sldValue / 10            ' Тиснение
    100.     Case 8: RunProcedure "Minimum", sldValue / 10           ' Минимум
    101.     Case 9: RunProcedure "Maximum", sldValue / 10           ' Максимум
    102.     Case 10: RunProcedure "FishEye", sldValue / 100         ' Рыбий глаз
    103.     End Select
    104.  
    105. End Sub
    106. ' // Загрузить картинку
    107. Private Sub LoadImage(Optional ByVal fileName As String)
    108.     Dim ofn     As OPENFILENAME
    109.     Dim title   As String
    110.     Dim out     As String
    111.     Dim filter  As String
    112.     Dim i       As Long
    113.     Dim dx      As Long
    114.     Dim dy      As Long
    115.     ' Если поток выполняется ждем завершения
    116.     If hThread Then WaitForSingleObject hThread, INFINITE
    117.     ' Если имя файла не задано, то показываем диалог открытия файла
    118.     If Len(fileName) = 0 Then
    119.         ofn.nMaxFile = 260
    120.         out = String(260, vbNullChar)
    121.         title = "Open image"
    122.         filter = "Picture file" & vbNullChar & "*.bmp;*.jpg" & vbNullChar
    123.         ofn.hwndOwner = Me.hWnd
    124.         ofn.lpstrTitle = StrPtr(title)
    125.         ofn.lpstrFile = StrPtr(out)
    126.         ofn.lStructSize = Len(ofn)
    127.         ofn.lpstrFilter = StrPtr(filter)
    128.         If GetOpenFileName(ofn) = 0 Then Exit Sub
    129.         ' Получаем имя файла
    130.         i = InStr(1, out, vbNullChar, vbBinaryCompare)
    131.         fileName = Left$(out, i - 1)
    132.     End If
    133.  
    134.     On Error Resume Next
    135.     ' Загружаем картинку
    136.     Set pic = LoadPicture(fileName)
    137.     If Err.Number Then MsgBox "Ошибка загрузки изображения", vbCritical: Exit Sub
    138.     On Error GoTo 0
    139.  
    140.     ' Установка постоянных атрибутов картинки
    141.     bi.bmiHeader.biSize = Len(bi.bmiHeader)
    142.     bi.bmiHeader.biBitCount = 32
    143.     bi.bmiHeader.biHeight = ScaleY(pic.Height, vbHimetric, vbPixels)
    144.     bi.bmiHeader.biWidth = ScaleX(pic.Width, vbHimetric, vbPixels)
    145.     bi.bmiHeader.biPlanes = 1
    146.     ' Массив пикселей
    147.     ReDim td.pix(bi.bmiHeader.biWidth * 4 - 1, bi.bmiHeader.biHeight - 1)
    148.     ' Проверка размеров
    149.     If bi.bmiHeader.biWidth > picCanvas.ScaleWidth Then
    150.         hsbScroll.Max = bi.bmiHeader.biWidth - picCanvas.ScaleWidth
    151.         hsbScroll.Visible = True
    152.         dx = -hsbScroll.value
    153.     Else
    154.         dx = (picCanvas.ScaleWidth - bi.bmiHeader.biWidth) / 2
    155.         hsbScroll.value = 0: hsbScroll.Visible = False
    156.     End If
    157.  
    158.     If bi.bmiHeader.biHeight > picCanvas.ScaleHeight Then
    159.         vsbScroll.Max = bi.bmiHeader.biHeight - picCanvas.ScaleHeight
    160.         vsbScroll.Visible = True
    161.         dy = -vsbScroll.value
    162.     Else
    163.         dy = (picCanvas.ScaleHeight - bi.bmiHeader.biHeight) / 2
    164.         vsbScroll.value = 0: vsbScroll.Visible = False
    165.     End If
    166.     ' Перемещаем картинку
    167.     picImage.Move dx, dy, bi.bmiHeader.biWidth, bi.bmiHeader.biHeight
    168.     ' Отображаем ее
    169.     cboEffect.ListIndex = 0: RunEffect
    170. End Sub
    171. ' // Запустить эффект в другом потоке
    172. Private Sub RunProcedure(Name As String, ByVal value As Single)
    173.     Dim lpProc As Long
    174.     ' Если в очереди уже есть вызов выходим
    175.     If quene Then Exit Sub
    176.     ' Если поток активен, то ставим в очередь текущий вызов и выходим
    177.     If hThread Then quene = True: Exit Sub
    178.     ' Получаем адрес функции
    179.     lpProc = GetProcAddress(hLib, Name)
    180.     If lpProc = 0 Then MsgBox "Невозможно найти функцию": Exit Sub
    181.     ' Устанавливаем значение эффекта
    182.     td.value = value
    183.     ' Получаем пиксели рисунка
    184.     GetDIBits picCanvas.hdc, pic.Handle, 0, bi.bmiHeader.biHeight, td.pix(0, 0), bi, 0
    185.     ' Создаем поток
    186.     hThread = CreateThread(ByVal 0&, 0, lpProc, td, 0, 0)
    187.     ' Включаем таймер прогрессбара
    188.     tmrUpdate.Enabled = True
    189. End Sub
    190. ' // Изменение величины эффекта
    191. Private Sub sldValue_Change()
    192.     RunEffect
    193. End Sub
    194. ' // Изменение типа эффекта
    195. Private Sub cboEffect_Click()
    196.     RunEffect
    197. End Sub
    198. ' // Таймер обновления
    199. Private Sub tmrUpdate_Timer()
    200.     Dim status  As Long
    201.     ' Устанавливаем процент
    202.     prgProgress.value = td.percent
    203.     ' Получаем код завершения потока
    204.     GetExitCodeThread hThread, status
    205.     ' Если поток активен, выходим
    206.     If status = STILL_ACTIVE Then Exit Sub
    207.     ' Поток завершился, отключаем таймер
    208.     tmrUpdate.Enabled = False
    209.     If status Then
    210.         ' Вызов удачен
    211.         ' Обновляем изображение
    212.         SetDIBitsToDevice picImage.hdc, 0, 0, bi.bmiHeader.biWidth, bi.bmiHeader.biHeight, 0, 0, 0, bi.bmiHeader.biHeight, td.pix(0, 0), bi, 0
    213.         picImage.Refresh
    214.     Else
    215.         ' При неудаче (функция эффекта возвратила 0)
    216.         MsgBox "Функция потерпела неудачу", vbExclamation
    217.     End If
    218.     ' Закрываем описатель
    219.     CloseHandle hThread
    220.     ' Поток завершен
    221.     hThread = 0
    222.     ' Если в очереди был вызов, то вызываем
    223.     If quene Then quene = False: RunEffect
    224. End Sub
    225. ' // Скроллбары ----------------------------+
    226. Private Sub vsbScroll_Change()          '   |
    227.     picImage.Top = -vsbScroll.value     '   |
    228. End Sub                                 '   |
    229. Private Sub vsbScroll_Scroll()          '   |
    230.     vsbScroll_Change                    '   |
    231. End Sub                                 '   |
    232. Private Sub hsbScroll_Change()          '   |
    233.     picImage.Left = -hsbScroll.value    '   |
    234. End Sub                                 '   |
    235. Private Sub hsbScroll_Scroll()          '   |
    236.     hsbScroll_Change                    '   |
    237. End Sub                                 '   |
    238. ' // ---------------------------------------+
    239.  
     
  9. Thetrik

    Thetrik UA6527P

    Публикаций:
    0
    Регистрация:
    25 июл 2011
    Сообщения:
    669
    Программа достаточно простая, все действия прокомментированы. Основные моменты я дополнительно поясню. При загрузке формы загружается наша DLL, и хендл библиотеки сохраняется в переменной hLib. Далее загружается изображение по умолчанию, расположенное в папке проекта. В процедуре загрузки изображения (LoadImage), заполняются основные поля структуры BITMAPINFO и выделяется массив под пиксели рисунка, для того чтобы потом можно было получить их через GetDiBits. Процедура RunEffect запускает функцию из DLL в отдельном потоке (RunProcedure). Для исключения запуска нескольких потоков в процедуре RunProcedure стоит проверка, если поток запущен, то установить переменную флаг (quene) и выйти не запуская ничего. Если поток не запущен, то получить пиксели через GetDiBits, и подготовив данные для потока (td), запустить функцию в отдельном потоке. Также при создании включается таймер обновления состояния. В процедуре таймера обновляется состояние прогрессбара исходя из значения переменной td.percent, и если поток успешно закончил свое выполнение (функция вернула не 0) обновляем данные в пикчербоксе через SetDIBitsToDevice. При окончании, если в переменной quene было True, то запускаем эффект, это позволит изменять значение величины эффекта или сам эффект пока идет обработка.
    [​IMG]
    Как видно из примера многопоточность отлично работает в VB6. К тому же эту DLL можно использовать в любом ЯП. В следующей части я опишу пример внедрения DLL и переопределение оконной процедуры, что даст возможность отслеживать различные события в других приложениях, перехватывать API функции и многое другое.
    Все вышеописанное является моим личным исследованием и поэтому могут быть любые "подводные камни", о которых я не знаю. О любых багах можете сообщать мне, я постараюсь решить. Отдельную благодарность хотелось бы выразить Владиславу Петровскому (aka. Хакер), за открытие недокументированных ключей компилятора/компоновщика.
     

    Вложения:

  10. Thetrik

    Thetrik UA6527P

    Публикаций:
    0
    Регистрация:
    25 июл 2011
    Сообщения:
    669
    Часть 3 - внедрение в чужой процесс.
    В прошлой части я написал о возможности создания потока в DLL, и о методе создания нативной DLL на VB6. Также я написал о том, что такая DLL будет работать в любом приложении, но примера не привел. В этой части мы напишем DLL которая будет выполняться в чужом 32-разрядном процессе и выполнять там наш код. В качестве примера сделаем приложение которое будет осуществлять сабклассинг окна в другом потоке и передавать в наше приложение сообщения, которые мы сможем обработать. Напишу сразу - DLL только для примера и не предназначена для работы в приложениях, т.к. имеются недостатки которые в качестве экономии кода я не устранял.
    Я решил сделать 3 случая использования:
    • Ограничение минимального размера перекрывающегося окна.
    • Отслеживания нажатий/отпусканий кнопок мыши в окне.
    • Лог сообщений.
    Итак, сначала нужно придумать механизм взаимодействия между процессами. Я решил пойти следующим путем:
    1. Для обмена данными между приложениями будем использовать проецированный в память файл.
    2. Для передачи сообщения от процесса-"жертвы" нашему приложению, будем использовать новое зарегистрированное сообщение.
    3. Для уведомления о завершении сабклассинга передавать сообщение будем в другую сторону.
    Теперь нужно продумать как осуществлять запуск. Ставим хук WH_GETMESSAGE на поток в котором содержится окно. Теперь наша DLL загрузится в АП процесса жертвы. В callback функции GetMsgProc при первом вызове будем инициализировать данные и устанавливать сабклассинг на нужное окно, для обмена как было сказано выше используем файл-маппинг.
     
  11. Thetrik

    Thetrik UA6527P

    Публикаций:
    0
    Регистрация:
    25 июл 2011
    Сообщения:
    669
    Итак код:
    Код (Visual Basic):
    1. ' modSubclassDLL.bas  - процедуры хука и сабклассинга
    2. ' © Кривоус Анатолий Анатольевич (The trick), 2014
    3. Option Explicit
    4. ' Эту структуру мы будем прередавать между процессами через файловое представление
    5. Public Type MsgData
    6.     hWnd    As Long     ' Хендл сабклассируемого окна
    7.     uMsg    As Long     ' Сообщение
    8.     wParam  As Long     ' Параметры
    9.     lParam  As Long     ' -
    10.     return  As Long     ' Возвращаемое значение
    11.     defCall As Long     ' Вызывать ли изначальную процедуру
    12. End Type
    13. Private Declare Function OpenFileMapping Lib "kernel32" Alias "OpenFileMappingW" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal lpName As Long) As Long
    14. Private Declare Function OpenMutex Lib "kernel32" Alias "OpenMutexW" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal lpName As Long) As Long
    15. 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
    16. Private Declare Function UnmapViewOfFile Lib "kernel32" (ByVal lpBaseAddress As Long) As Long
    17. Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
    18. Private Declare Function GetMem4 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
    19. Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
    20. Private Declare Function ReleaseMutex Lib "kernel32" (ByVal hMutex As Long) As Long
    21. Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Integer, lParam As Any) As Long
    22. 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
    23. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    24. Private Declare Function SetProp Lib "user32" Alias "SetPropW" (ByVal hWnd As Long, ByVal lpString As Long, ByVal hData As Long) As Long
    25. Private Declare Function RemoveProp Lib "user32" Alias "RemovePropW" (ByVal hWnd As Long, ByVal lpString As Long) As Long
    26. Private Declare Function GetProp Lib "user32" Alias "GetPropW" (ByVal hWnd As Long, ByVal lpString As Long) As Long
    27. Private Declare Function GlobalAddAtom Lib "kernel32" Alias "GlobalAddAtomW" (ByVal lpString As Long) As Integer
    28. Private Declare Function GlobalDeleteAtom Lib "kernel32" (ByVal nAtom As Integer) As Integer
    29. Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageW" (ByVal lpString As Long) As Long
    30. 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
    31. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    32. Private Const GWL_WNDPROC        As Long = (-4)
    33. Private Const INFINITE           As Long = -1&
    34. Private Const MUTEX_ALL_ACCESS   As Long = &H1F0001
    35. Private Const FILE_MAP_READ      As Long = &H4
    36. Private Const FILE_MAP_WRITE     As Long = &H2
    37. Private Const WAIT_FAILED        As Long = -1&
    38. Private WM_SENDMESSAGE   As Long    ' Наше сообщение для обмена с основной программой. Отсылая из текущего потока это сообщение
    39.                                     ' в наше приложение (TestSubclassDLL), мы уведомляем приложение через SendMessage о том, что
    40.                                     ' пришло новое сообщение, параметры которого записаны в файловое представление. Передавая из
    41.                                     ' главного (TestSubclassDLL) приложения сюда это сообщение, мы уведомляем о том, что нужно
    42.                                     ' снять сабклассинг и выполнить деинициализацию.
    43.    
    44. Dim hMutex      As Long     ' Описатель мьютекса для синхронизации чтения/записи общих данных
    45. Dim hMap        As Long     ' Хендл файлового отображения
    46. Dim lpShrdData  As Long     ' Адрес общих данных
    47. Dim hWndServer  As Long     ' Хендл окна для приема и обработки сообщений
    48. Dim hWndHook    As Long     ' Хендл сабклассируемого окна в этом процессе
    49. Dim hHook       As Long     ' Хендл хука, для передачи в CallNextHookEx
    50. Dim aPrevProc   As Integer  ' Атом имени свойства изначальной оконной процедуры
    51. Dim init        As Boolean  ' Инициализирован ли сабклассинг
    52. Dim disabled    As Boolean  ' Сабклассинг окончен.
    53. ' // Процедура хука
    54. Public Function GetMsgProc(ByVal code As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    55.     Dim prevProc    As Long
    56.     ' Если не инициализирован сабклассинг - инициализируем
    57.     If Not (init Or disabled) Then
    58.         ' Открываем проекцию
    59.         hMap = OpenFileMapping(FILE_MAP_WRITE, False, StrPtr("TrickSubclassFileMap"))
    60.         If hMap = 0 Then MsgBox "Невозможно открыть проекцию", vbCritical: Clear: Exit Function
    61.         ' Проецируем
    62.         lpShrdData = MapViewOfFile(hMap, FILE_MAP_WRITE, 0, 0, 0)
    63.         CloseHandle hMap: hMap = 0
    64.         If lpShrdData = 0 Then MsgBox "Невозможно отобразить представление", vbCritical: Clear: Exit Function
    65.         ' Открываем синхронизирующий мьютекс
    66.         hMutex = OpenMutex(MUTEX_ALL_ACCESS, False, StrPtr("TrickSubclassMutex"))
    67.         If hMutex = 0 Then MsgBox "Невозможно отрыть мьютекс", vbCritical: Clear: Exit Function
    68.         ' Регистрация сообщения
    69.         WM_SENDMESSAGE = RegisterWindowMessage(StrPtr(WM_SENDMESSAGE))
    70.         If WM_SENDMESSAGE = 0 Then MsgBox "Невозможно Зарегистрировать сообщение", vbCritical: Clear: Exit Function
    71.         ' Добавляем/получаем атом для сохранения предыдущей оконной процедуры
    72.         aPrevProc = GlobalAddAtom(StrPtr("prevProc"))
    73.         If aPrevProc = 0 Then MsgBox "Невозможно добавить атом", vbCritical: Clear: Exit Function
    74.         ' Захватываем мьютекс. Если например в главном приложении еще не произошел выход из SetWindowsHookEx, то
    75.         ' еще неизвестен хендл хука, а т.к. у нас там уже захвачен этот мьютекс, то этот поток будет ждать пока
    76.         ' мьютекс не освободится, что произойдет только после записи хендля хука в общую память и остальных данных
    77.         If WaitForSingleObject(hMutex, INFINITE) = WAIT_FAILED Then MsgBox "Ошибка ожидания", vbCritical: Clear: Exit Function
    78.         ' Получаем хендл окна, которое будет принимать сообщения
    79.         GetMem4 ByVal lpShrdData, hWndServer
    80.         ' Получаем хендл сабклассируемого окна
    81.         GetMem4 ByVal lpShrdData + 4, hWndHook
    82.         ' Получаем хендл хука
    83.         GetMem4 ByVal lpShrdData + 8, hHook
    84.         ' Освобождаем мьютекс
    85.         ReleaseMutex hMutex
    86.         ' Получаем адрес оконной процедуры и задаем новый
    87.         prevProc = SetWindowLong(hWndHook, GWL_WNDPROC, AddressOf WndProc)
    88.         If prevProc = 0 Then MsgBox "Невозможно заменить оконную процедуру", vbCritical: Clear: Exit Function
    89.         ' Установка свойства окна
    90.         SetProp hWndHook, CLng(aPrevProc) And &HFFFF&, prevProc
    91.         ' Успех
    92.         init = True
    93.     End If
    94.     ' Передаем на обработку другим процедурам
    95.     GetMsgProc = CallNextHookEx(hHook, code, wParam, lParam)
    96. End Function
    97. ' // Деинициализация
    98. Public Sub Clear()
    99.     If hMutex Then CloseHandle (hMutex): hMutex = 0
    100.     If lpShrdData Then UnmapViewOfFile (lpShrdData): lpShrdData = 0
    101.     If hWndHook Then RemoveProp hWndHook, CLng(aPrevProc) And &HFFFF&: hWndHook = 0
    102.     If aPrevProc Then GlobalDeleteAtom (aPrevProc): aPrevProc = 0
    103.     init = False
    104. End Sub
    105. ' // Оконная процедура
    106. Private Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    107.     Dim sendData    As MsgData
    108.     Dim prevProc    As Long
    109.     ' Проверяем не снятие ли сабклассинга
    110.     If uMsg = WM_SENDMESSAGE Then
    111.         ' Получаем предыдущий адрес процедуры
    112.         prevProc = GetProp(hWnd, CLng(aPrevProc) And &HFFFF&)
    113.         ' Устанавливаем его оконной процедуре
    114.         SetWindowLong hWnd, GWL_WNDPROC, prevProc
    115.         ' Очистка
    116.         Clear
    117.         ' Отключаем сабклассинг
    118.         ' Возможна ситуация когда будет вызвана GetMsgProc, до того, как будет снят хук в главно приложении
    119.         ' этот флаг предотвращает повторную инициализацию данных.
    120.         disabled = True
    121.         Exit Function
    122.         ' Теперь из главного приложения будет вызвана UnhookWindowsHookEx и наша DLL будет выгружена из памяти.
    123.     End If
    124.     ' Формируем запрос
    125.     sendData.hWnd = hWnd
    126.     sendData.uMsg = uMsg
    127.     sendData.wParam = wParam
    128.     sendData.lParam = lParam
    129.     sendData.defCall = True
    130.     ' Захватываем мьютекс
    131.     If WaitForSingleObject(hMutex, INFINITE) = WAIT_FAILED Then MsgBox "Ошибка ожидания", vbCritical: Clear: Exit Function
    132.     CopyMemory ByVal lpShrdData + 12, sendData, Len(sendData)
    133.     ' Освобождаем мьютекс
    134.     ReleaseMutex hMutex
    135.     ' Отправляем сообщение главному окну
    136.     SendMessage hWndServer, WM_SENDMESSAGE, 0, ByVal 0
    137.     ' Получаем результат обработки
    138.     If WaitForSingleObject(hMutex, INFINITE) = WAIT_FAILED Then MsgBox "Ошибка ожидания", vbCritical: Clear: Exit Function
    139.     CopyMemory sendData, ByVal lpShrdData + 12, Len(sendData)
    140.     ' Освобождаем мьютекс
    141.     ReleaseMutex hMutex
    142.     ' Следует ли обрабатывать его дальше
    143.     If sendData.defCall Then
    144.         prevProc = GetProp(hWnd, CLng(aPrevProc) And &HFFFF&)
    145.         WndProc = CallWindowProc(prevProc, sendData.hWnd, sendData.uMsg, sendData.wParam, sendData.lParam)
    146.     Else
    147.         WndProc = sendData.return
    148.     End If
    149. End Function
    150.  
     
  12. Thetrik

    Thetrik UA6527P

    Публикаций:
    0
    Регистрация:
    25 июл 2011
    Сообщения:
    669
    Разберем подробно код. В процедуре инициализации проверяем флаги инициализации и отключения сабклассинга. Если какой-либо True, то значит либо сабклассинг установлен, либо закончен. Иначе начинаем инициализацию. Первым делом открываем файл-маппинг и проецируем представление на АП процесса. Для избежания состояния гонки используем синхронизирующий объект мьютекс. Потом регистрируем сообщение WM_SENDMESSAGE для обмена в системе и получаем его номер. Для хранения адреса предыдущей оконной процедуры я решил использовать свойство окна, хотя можно было бы использовать и переменную модуля, т.к. за раз можно только перехватить только одно окно в этой реализации. Для ускоренного доступа к свойству я использую атом, поэтому регистрируем его с именем prevProc. Потом пытаемся захватить мьютекс. Когда это удается, то общие данные доступны только для этого потока, никакой другой поток не сможет что-то записать туда и мы избежим состояния гонки. Из файл-маппинга достаем нужные нам данные (хендл главного окна нашего приложения, хендл сабклассируемого окна и хендл хука, его нужно передать в CallNextHookEx). Позже освобождаем мьютекс, и устанавливаем адрес оконной процедуры на наш (сабклассируем окно). Теперь все сообщения предназначенные для окна пойдут в процедуру WndProc.
    Разберем процедуру WndProc. Для начала разберем структуру файл-маппинга:
    [​IMG]
    Проверяем сообщение, если это наше зарегистрированное, то его может отправить только наше приложение при снятии сабклассинга, поэтому выполняем деинициализацию. Иначе формируем данные сообщения и, захватив мьютекс, пишем их в файл маппинг со смещения 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 из памяти процесса-"жертвы".
    [​IMG]
    Как мы увидели DLL, написанная на VB6, отлично работает в чужих программах и потоках. Данная DLL написана только для тестирования и демонстрации возможностей VB6. Я не ставил перед собой задачи написания законченной DLL для использования в проектах, поэтому DLL намеренно обладает ограничениями и имеет неправильную архитектуру (нельзя делать множественный сабклассинг и другие ограничения и баги), отсутствуют проверки. Для демонстрации возможностей этого достаточно. Как мы могли убедиться что многопоточность вполне работает в программах написанных на VB6, и DLL, написанные на VB6 работают в любых программах.
     

    Вложения:

  13. Thetrik

    Thetrik UA6527P

    Публикаций:
    0
    Регистрация:
    25 июл 2011
    Сообщения:
    669
    Часть 4 - многопоточность в Standart EXE.
    Сейчас я опять буду говорить о многопоточности, на этот раз в Standart EXE. Сразу скажу что все о чем я пишу является моим личным исследованием и может в чем-то не соответствовать действительности; также из-за моего недостатка времени я буду дополнять этот пост по мере дальнейшего прогресса в исследовании данного вопроса. Итак начнем.
    Как я говорил до этого для того чтобы многопоточность работала нужно инициализировать рантайм. Без инициализации мы можем работать очень ограниченно, в том смысле что COM не будет работать, т.е. грубо говоря вся мощь бейсика будет недоступна. Можно работать с API, объявленными в tlb, некоторыми функциями, также убирая проверку __vbaSetSystemError, можно использовать Declared-функции. Все предыдущие публикации показывали работу в отдельных DLL, и мы легко могли инициализировать рантайм используя VBDllGetClassObject функцию для этого. Сегодня мы попытаемся инициализировать рантайм в обычном EXE, т.е. не используя внешние зависимости. Не для кого не секрет что любое приложение написанное в VB6 состоит из хидера проекта, в котором содержится очень много информации о проекте которую рантайм использует для работы:
    Код (Visual Basic):
    1. Type VbHeader
    2.     szVbMagic               As String * 4
    3.     wRuntimeBuild           As Integer
    4.     szLangDll               As String * 14
    5.     szSecLangDll            As String * 14
    6.     wRuntimeRevision        As Integer
    7.     dwLCID                  As Long
    8.     dwSecLCID               As Long
    9.     lpSubMain               As Long
    10.     lpProjectInfo           As Long
    11.     fMdlIntCtls             As Long
    12.     fMdlIntCtls2            As Long
    13.     dwThreadFlags           As Long
    14.     dwThreadCount           As Long
    15.     wFormCount              As Integer
    16.     wExternalCount          As Integer
    17.     dwThunkCount            As Long
    18.     lpGuiTable              As Long
    19.     lpExternalCompTable     As Long
    20.     lpComRegisterData       As Long
    21.     bszProjectDescription   As Long
    22.     bszProjectExeName       As Long
    23.     bszProjectHelpFile      As Long
    24.     bszProjectName          As Long
    25. End Type
    В этой структуре большое количество полей описывать все я не буду, отмечу только что эта структура ссылается на множество других структур. Некоторые из них нам понадобятся в дальнейшем, например поле lpSubMain, в котором содержится адрес процедуры Main, если она определена, иначе там 0.
    Подавляющее большинство EXE файлов начинаются со следующего кода:
    Код (ASM):
    1. PUSH xxxxxxxx
    2. 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):
    1. ' // Get VBHeader structure
    2. Private Function GetVBHeader() As Long
    3.     Dim ptr     As Long
    4.     ' Get e_lfanew
    5.     GetMem4 ByVal hModule + &H3C, ptr
    6.     ' Get AddressOfEntryPoint
    7.     GetMem4 ByVal ptr + &H28 + hModule, ptr
    8.     ' Get VBHeader
    9.     GetMem4 ByVal ptr + hModule + 1, GetVBHeader
    10.    
    11. End Function
    Теперь если передать эту структуру функции VBDllGetClassObject в новом потоке, то, грубо говоря, эта функция запустит наш проект на выполнение согласно переданной структуре. Конечно смысла в этом мало - это тоже самое что начать выполнение приложения заново в новом потоке. Например если была задана функция Main, то и выполнение начнется опять с нее, а если была форма, то с нее. Нужно как-то сделать так, чтобы проект выполнялся с другой, нужной нам, функции. Для этого можно изменить поле lpSubMain структуры vbHeader. Я тоже сначала сделал так, но это ничего не дало. Как выяснилось, внутри рантайма есть один глобальный объект, который хранит ссылки на проекты и связанные с ними объекты и если передать тот же самый хидер в VBDllGetClassObject, то рантайм проверит, не загружался ли такой проект, и если загружался, то просто запустит новую копию без разбора структуры vbHeader, на основании предыдущего разбора. Поэтому я решил поступить так - можно скопировать структуру vbHeader в другое место и использовать ее. Сразу замечу, что в этой структуре последние 4 поля - это смещения относительно начала структуры, поэтому при копировании струкутуры их нужно будет скорректировать. Если теперь попробовать передать эту структуру в VBDllGetClassObject, то все будет отлично если в качестве стартапа установлена Sub Main, если же форма, то будет запущена и форма и после нее Main. Для исключения такого поведения нужно поправить кое-какие данные на которые ссылается хидер. Я пока точно не знаю что это за данные, т.к. не разбирался в этом, но "поковырявшись" внутри рантайма я нашел их место положение. Поле lpGuiTable структуры vbHeader ссылается на список структур tGuiTable, которые описывают формы в проекте. Структуры идут последовательно, число структур соответствует полю wFormCount структуры vbHeader. В сети я так и не нашел нормальное описание структуры tGuiTable, вот что есть:
    Код (Visual Basic):
    1. Type tGuiTable
    2.     lStructSize          As Long
    3.     uuidObjectGUI        As uuid
    4.     Unknown1             As Long
    5.     Unknown2             As Long
    6.     Unknown3             As Long
    7.     Unknown4             As Long
    8.     lObjectID            As Long
    9.     Unknown5             As Long
    10.     fOLEMisc             As Long
    11.     uuidObject           As uuid
    12.     Unknown6             As Long
    13.     Unknown7             As Long
    14.     aFormPointer         As Long
    15.     Unknown8             As Long
    16. End Type
    Как выяснилось внутри рантайма есть код, который проверяет поле Unknown5 каждой структуры:
    [​IMG]
    Я проставил комментарии; из них видно что Unknown5 содержит флаги и если установлен 5-й бит, то происходит запись ссылки на какой-то объект, заданный регистром EAX, в поле со смещением 0x30 объекта заданного регистром EDX. Что за объекты - я не знаю, возможно позже разберусь с этим, нам важен сам факт записи какого-то значения в поле со смещением 0x30. Теперь, если дальше начать исследовать код то можно наткнутся на такой фрагмент:
    [​IMG]
    Скажу что объект на который указывает ESI, тот же самый объект что в предыдущей рассматриваемой процедуре (регистр EDX). Видно что тестируется значение этого поля на -1 и на 0, и если там любое из этих чисел то запускается процедура Main (если она задана); иначе запускается первая форма.
    Итак, теперь чтобы гарантированно запускать только Sub Main, мы изменяем флаг lpGuiTable.Unknown5, сбрасывая пятый бит. Для установки новой Sub Main и модификации флага я создал отдельную процедуру:
    Код (Visual Basic):
    1. ' // Modify VBHeader to replace Sub Main
    2. Private Sub ModifyVBHeader(ByVal newAddress As Long)
    3.     Dim ptr     As Long
    4.     Dim old     As Long
    5.     Dim flag    As Long
    6.     Dim count   As Long
    7.     Dim size    As Long
    8.    
    9.     ptr = lpVBHeader + &H2C
    10.     ' Are allowed to write in the page
    11.     VirtualProtect ByVal ptr, 4, PAGE_READWRITE, old
    12.     ' Set a new address of Sub Main
    13.     GetMem4 newAddress, ByVal ptr
    14.     VirtualProtect ByVal ptr, 4, old, 0
    15.    
    16.     ' Remove startup form
    17.     GetMem4 ByVal lpVBHeader + &H4C, ptr
    18.     ' Get forms count
    19.     GetMem4 ByVal lpVBHeader + &H44, count
    20.    
    21.     Do While count > 0
    22.         ' Get structure size
    23.         GetMem4 ByVal ptr, size
    24.         ' Get flag (unknown5) from current form
    25.         GetMem4 ByVal ptr + &H28, flag
    26.         ' When set, bit 5,
    27.         If flag And &H10 Then
    28.             ' Unset bit 5
    29.             flag = flag And &HFFFFFFEF
    30.             ' Are allowed to write in the page
    31.             VirtualProtect ByVal ptr, 4, PAGE_READWRITE, old
    32.             ' Write changet flag
    33.             GetMem4 flag, ByVal ptr + &H28
    34.             ' Restoring the memory attributes
    35.             VirtualProtect ByVal ptr, 4, old, 0
    36.            
    37.         End If
    38.         count = count - 1
    39.         ptr = ptr + size
    40.        
    41.     Loop
    42.    
    43. End Sub
     
  14. Thetrik

    Thetrik UA6527P

    Публикаций:
    0
    Регистрация:
    25 июл 2011
    Сообщения:
    669
    Теперь, если попробовать запустить эту процедуру перед передачей хидера в VBDllGetClassObject, то будет запускаться процедура, определенная нами. Впрочем многопоточность уже будет работать, но это не удобно, т.к. отсутствует механизм передачи параметра в поток как это реализовано в CreateThread. Для того чтобы сделать полный аналог CreateThread я решил создать аналогичную функцию, которая будет проводить все инициализации и после выполнять вызов переданной функции потока вместе с параметром. Для того чтобы была возможность передать параметр в Sub Main, я использовал локальное хранилище потока (TLS). Мы выделяем индекс для TLS. После выделения индекса мы сможем задавать значение этого индекса, специфичное для каждого потока. В общем идея такова, создаем новый поток, где стартовой функцией будет специальная функция ThreadProc, в параметр которой передаем структуру из двух полей - адреса пользовательской функции и адреса параметра. В этой процедуре мы будем инициализировать рантайм для нового потока и сохранять в TLS переданный параметр. В качестве процедуры Main создадим бинарный код, который будет доставать данные из TLS, формировать стек и прыгать на пользовательскую функцию.
    В итоге получился такой модуль:
    modMultiThreading.bas
    Код (Visual Basic):
    1. ' modMultiThreading.bas - The module provides support for multi-threading.
    2. ' © Кривоус Анатолий Анатольевич (The trick), 2015
    3. Option Explicit
    4. Private Type uuid
    5.     data1       As Long
    6.     data2       As Integer
    7.     data3       As Integer
    8.     data4(7)    As Byte
    9. End Type
    10. Private Type threadData
    11.     lpParameter As Long
    12.     lpAddress   As Long
    13. End Type
    14. Private tlsIndex    As Long  ' Index of the item in the TLS. There will be data specific to the thread.
    15. Private lpVBHeader  As Long  ' Pointer to VBHeader structure.
    16. Private hModule     As Long  ' Base address.
    17. Private lpAsm       As Long  ' Pointer to a binary code.
    18. ' // Create a new thread
    19. Public Function vbCreateThread(ByVal lpThreadAttributes As Long, _
    20.                                ByVal dwStackSize As Long, _
    21.                                ByVal lpStartAddress As Long, _
    22.                                ByVal lpParameter As Long, _
    23.                                ByVal dwCreationFlags As Long, _
    24.                                lpThreadId As Long) As Long
    25.     Dim InIDE   As Boolean
    26.  
    27.     Debug.Assert MakeTrue(InIDE)
    28.  
    29.     If InIDE Then
    30.         Dim ret As Long
    31.    
    32.         ret = MsgBox("Multithreading not working in IDE." & vbNewLine & "Run it in the same thread?", vbQuestion Or vbYesNo)
    33.         If ret = vbYes Then
    34.             ' Run function in main thread
    35.             ret = DispCallFunc(ByVal 0&, lpStartAddress, CC_STDCALL, vbEmpty, 1, vbLong, VarPtr(CVar(lpParameter)), CVar(0))
    36.             If ret Then
    37.                 Err.Raise ret
    38.             End If
    39.         End If
    40.    
    41.         Exit Function
    42.     End If
    43.  
    44.     ' Alloc new index from thread local storage
    45.     If tlsIndex = 0 Then
    46.    
    47.         tlsIndex = TlsAlloc()
    48.    
    49.         If tlsIndex = 0 Then Exit Function
    50.    
    51.     End If
    52.     ' Get module handle
    53.     If hModule = 0 Then
    54.    
    55.         hModule = GetModuleHandle(ByVal 0&)
    56.    
    57.     End If
    58.     ' Create assembler code
    59.     If lpAsm = 0 Then
    60.    
    61.         lpAsm = CreateAsm()
    62.         If lpAsm = 0 Then Exit Function
    63.    
    64.     End If
    65.     ' Get pointer to VBHeader and modify
    66.     If lpVBHeader = 0 Then
    67.  
    68.         lpVBHeader = GetVBHeader()
    69.         If lpVBHeader = 0 Then Exit Function
    70.    
    71.         ModifyVBHeader lpAsm
    72.    
    73.     End If
    74.  
    75.     Dim lpThreadData    As Long
    76.     Dim tmpData         As threadData
    77.     ' Alloc thread-specific memory for threadData structure
    78.     lpThreadData = HeapAlloc(GetProcessHeap(), 0, Len(tmpData))
    79.  
    80.     If lpThreadData = 0 Then Exit Function
    81.     ' Set parameters
    82.     tmpData.lpAddress = lpStartAddress
    83.     tmpData.lpParameter = lpParameter
    84.     ' Copy parameters to thread-specific memory
    85.     GetMem8 tmpData, ByVal lpThreadData
    86.     ' Create thread
    87.     vbCreateThread = CreateThread(ByVal lpThreadAttributes, _
    88.                                   dwStackSize, _
    89.                                   AddressOf ThreadProc, _
    90.                                   ByVal lpThreadData, _
    91.                                   dwCreationFlags, _
    92.                                   lpThreadId)
    93.  
    94. End Function
    95. ' // Initialize runtime for new thread and run procedure
    96. Private Function ThreadProc(lpParameter As threadData) As Long
    97.     Dim iid         As uuid
    98.     Dim clsid       As uuid
    99.     Dim lpNewHdr    As Long
    100.     Dim hHeap       As Long
    101.     ' Initialize COM
    102.     vbCoInitialize ByVal 0&
    103.     ' IID_IUnknown
    104.     iid.data4(0) = &HC0: iid.data4(7) = &H46
    105.     ' Store parameter to thread local storage
    106.     TlsSetValue tlsIndex, lpParameter
    107.     ' Create the copy of VBHeader
    108.     hHeap = GetProcessHeap()
    109.     lpNewHdr = HeapAlloc(hHeap, 0, &H6A)
    110.     CopyMemory ByVal lpNewHdr, ByVal lpVBHeader, &H6A
    111.     ' Adjust offsets
    112.     Dim names()     As Long
    113.     Dim diff        As Long
    114.     Dim Index       As Long
    115.  
    116.     ReDim names(3)
    117.     diff = lpNewHdr - lpVBHeader
    118.     CopyMemory names(0), ByVal lpVBHeader + &H58, &H10
    119.  
    120.     For Index = 0 To 3
    121.         names(Index) = names(Index) - diff
    122.     Next
    123.  
    124.     CopyMemory ByVal lpNewHdr + &H58, names(0), &H10
    125.     ' This line calls the binary code that runs the asm function.
    126.     VBDllGetClassObject VarPtr(hModule), 0, lpNewHdr, clsid, iid, 0
    127.     ' Free memeory
    128.     HeapFree hHeap, 0, ByVal lpNewHdr
    129.     HeapFree hHeap, 0, lpParameter
    130.  
    131. End Function
    132. ' // Get VBHeader structure
    133. Private Function GetVBHeader() As Long
    134.     Dim ptr     As Long
    135.  
    136.     ' Get e_lfanew
    137.     GetMem4 ByVal hModule + &H3C, ptr
    138.     ' Get AddressOfEntryPoint
    139.     GetMem4 ByVal ptr + &H28 + hModule, ptr
    140.     ' Get VBHeader
    141.     GetMem4 ByVal ptr + hModule + 1, GetVBHeader
    142.  
    143. End Function
    144. ' // Modify VBHeader to replace Sub Main
    145. Private Sub ModifyVBHeader(ByVal newAddress As Long)
    146.     Dim ptr     As Long
    147.     Dim old     As Long
    148.     Dim flag    As Long
    149.     Dim count   As Long
    150.     Dim size    As Long
    151.  
    152.     ptr = lpVBHeader + &H2C
    153.     ' Are allowed to write in the page
    154.     VirtualProtect ByVal ptr, 4, PAGE_READWRITE, old
    155.     ' Set a new address of Sub Main
    156.     GetMem4 newAddress, ByVal ptr
    157.     VirtualProtect ByVal ptr, 4, old, 0
    158.  
    159.     ' Remove startup form
    160.     GetMem4 ByVal lpVBHeader + &H4C, ptr
    161.     ' Get forms count
    162.     GetMem2 ByVal lpVBHeader + &H44, count
    163.  
    164.     Do While count > 0
    165.         ' Get structure size
    166.         GetMem4 ByVal ptr, size
    167.         ' Get flag (unknown5) from current form
    168.         GetMem4 ByVal ptr + &H28, flag
    169.         ' When set, bit 5,
    170.         If flag And &H10 Then
    171.             ' Unset bit 5
    172.             flag = flag And &HFFFFFFEF
    173.             ' Are allowed to write in the page
    174.             VirtualProtect ByVal ptr, 4, PAGE_READWRITE, old
    175.             ' Write changet flag
    176.             GetMem4 flag, ByVal ptr + &H28
    177.             ' Restoring the memory attributes
    178.             VirtualProtect ByVal ptr, 4, old, 0
    179.        
    180.         End If
    181.    
    182.         count = count - 1
    183.         ptr = ptr + size
    184.    
    185.     Loop
    186.  
    187. End Sub
    188. ' // Create binary code.
    189. Private Function CreateAsm() As Long
    190.     Dim hMod    As Long
    191.     Dim lpProc  As Long
    192.     Dim ptr     As Long
    193.  
    194.     hMod = GetModuleHandle(ByVal StrPtr("kernel32"))
    195.     lpProc = GetProcAddress(hMod, "TlsGetValue")
    196.  
    197.     If lpProc = 0 Then Exit Function
    198.  
    199.     ptr = VirtualAlloc(ByVal 0&, &HF, MEM_RESERVE Or MEM_COMMIT, PAGE_EXECUTE_READWRITE)
    200.  
    201.     If ptr = 0 Then Exit Function
    202.  
    203.     ' push  tlsIndex
    204.     ' call  TLSGetValue
    205.     ' pop   ecx
    206.     ' push  DWORD [eax]
    207.     ' push  ecx
    208.     ' jmp   DWORD [eax + 4]
    209.  
    210.     GetMem4 &H68, ByVal ptr + &H0:          GetMem4 &HE800, ByVal ptr + &H4
    211.     GetMem4 &HFF590000, ByVal ptr + &H8:    GetMem4 &H60FF5130, ByVal ptr + &HC
    212.     GetMem4 &H4, ByVal ptr + &H10:          GetMem4 tlsIndex, ByVal ptr + 1
    213.     GetMem4 lpProc - ptr - 10, ByVal ptr + 6
    214.  
    215.     CreateAsm = ptr
    216.  
    217. End Function
    218. Private Function MakeTrue(value As Boolean) As Boolean
    219.     MakeTrue = True: value = True
    220. End Function
    221.  
    Все API декларации я сделал в отдельной библиотеке типов - EXEInitialize.tlb. Пока найден один недостаток - не работают формы с приватными контролами, если разберусь в чем причина - исправлю. Работает только в скомпилированном варианте.
    В архиве содержится несколько тестов.
    1-й: создание формы в новом потоке, с возможностью блокировки ввода посредством длинного цикла.
    2-й: обработка событий от объекта, метод которого вызван в другом потоке. Сразу скажу так делать нельзя и неправильно, т.к. передавать между потоками ссылку без маршаллинга опасно и может привести к глюкам, к тому же обработка события выполняется в другом потоке. Этот пример я оставил в качестве демонстрации работы многопоточности, а не для использования в повседневных задачах.
    3-й: демонстрация изменения значения общей переменной в одном потоке и считывание его из другого. В IDE запуск осуществляется в главном потоке по желанию.
    Добавлена нативная DLL которая экспортирует vbCreateThread.
    Всем удачи!
     

    Вложения: