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

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

Полезные ссылки:
user posted image FAQ Сайта user posted image FAQ Раздела user posted image Кладовка user posted image Наши Исходники user posted image API-Guide user posted image Поиск по Разделу user posted image MSDN Library Online user posted image Google
Ваше мнение о модераторах: user posted image SCINER, user posted image B.V.
Модераторы: SCINER, B.V.
Ссылки по теме:
  
> Многопоточность в VB6 часть 4 , Многопоточность в Standart EXE.
TheTrik
Сообщ. #1 ,
    Full Member
    ***
    Профиль · PM
    Поощрения: 10 Dgm
    Рейтинг (т): 29
    Всем привет. Сейчас у меня мало времени, поэтому я уже не так часто уделяю внимание бейсику и реже появляюсь на форумах. Сегодня я опять буду говорить о многопоточности, на этот раз в Standart EXE. Сразу скажу что все о чем я пишу является моим личным исследованием и может в чем-то не соответствовать действительности; также из-за моего недостатка времени я буду дополнять этот пост по мере дальнейшего прогресса в исследовании данного вопроса. Итак начнем.
    Как я говорил до этого для того чтобы многопоточность работала нужно инициализировать рантайм. Без инициализации мы можем работать очень ограниченно, в том смысле что COM не будет работать, т.е. грубо говоря вся мощь бейсика будет недоступна. Можно работать с API, объявленными в tlb, некоторыми функциями, также убирая проверку __vbaSetSystemError, можно использовать Declared-функции. Все предыдущие публикации показывали работу в отдельных DLL, и мы легко могли инициализировать рантайм используя VBDllGetClassObject функцию для этого. Сегодня мы попытаемся инициализировать рантайм в обычном EXE, т.е. не используя внешние зависимости. Не для кого не секрет что любое приложение написанное в VB6 состоит из хидера проекта, в котором содержится очень много информации о проекте которую рантайм использует для работы:
    ExpandedWrap disabled
      Type VbHeader
          szVbMagic               As String * 4
          wRuntimeBuild           As Integer
          szLangDll               As String * 14
          szSecLangDll            As String * 14
          wRuntimeRevision        As Integer
          dwLCID                  As Long
          dwSecLCID               As Long
          lpSubMain               As Long
          lpProjectInfo           As Long
          fMdlIntCtls             As Long
          fMdlIntCtls2            As Long
          dwThreadFlags           As Long
          dwThreadCount           As Long
          wFormCount              As Integer
          wExternalCount          As Integer
          dwThunkCount            As Long
          lpGuiTable              As Long
          lpExternalCompTable     As Long
          lpComRegisterData       As Long
          bszProjectDescription   As Long
          bszProjectExeName       As Long
          bszProjectHelpFile      As Long
          bszProjectName          As Long
      End Type

    В этой структуре большое количество полей описывать все я не буду, отмечу только что эта структура ссылается на множество других структур. Некоторые из них нам понадобятся в дальнейшем, например поле lpSubMain, в котором содержится адрес процедуры Main, если она определена, иначе там 0.
    Подавляющее большинство EXE файлов начинаются со следующего кода:
    ExpandedWrap disabled
      PUSH xxxxxxxx
      CALL MSVBVM60.ThunRTMain

    Как раз xxxxxxxx указывает на структуру VBHeader. Эта особенность позволит найти эту структуру внутри EXE для инициализации рантайма. В одной из предыдущих частей я описывал как достать из ActiveX DLL эту структуру - для этого нужно было считать данные в одной из экспортируемых функций (к примеру DllGetClassObject). Для получения из EXE - мы также воспользуемся тем-же методом. Для начала нужно найти точку входа (entry point), т.е. адрес с которого начинается выполнение EXE. Этот адрес можно получить из структуры IMAGE_OPTIONAL_HEADER - поле AddressOfEntryPoint. Сама структура IMAGE_OPTIONAL_HEADER расположена в PE заголовке, а PE заголовок находится по смещению заданному в поле e_lfanew структуры IMAGE_DOS_HEADER, ну а структура IMAGE_DOS_HEADER расположена по адресу App.hInstance (или GetModuleHandle). Указатель на VbHeader будет лежать по смещению AddressOfEntryPoint + 1, т.к. опкод команды push в данном случае 0x68h. Итак, собирая все вместе, получим функцию для получения хидера:
    ExpandedWrap disabled
      ' // Get VBHeader structure
      Private Function GetVBHeader() As Long
          Dim ptr     As Long
          ' Get e_lfanew
          GetMem4 ByVal hModule + &H3C, ptr
          ' Get AddressOfEntryPoint
          GetMem4 ByVal ptr + &H28 + hModule, ptr
          ' Get VBHeader
          GetMem4 ByVal ptr + hModule + 1, GetVBHeader
          
      End Function

    Теперь если передать эту структуру функции VBDllGetClassObject в новом потоке, то, грубо говоря, эта функция запустит наш проект на выполнение согласно переданной структуре. Конечно смысла в этом мало - это тоже самое что начать выполнение приложения заново в новом потоке. Например если была задана функция Main, то и выполнение начнется опять с нее, а если была форма, то с нее. Нужно как-то сделать так, чтобы проект выполнялся с другой, нужной нам, функции. Для этого можно изменить поле lpSubMain структуры vbHeader. Я тоже сначала сделал так, но это ничего не дало. Как выяснилось, внутри рантайма есть один глобальный объект, который хранит ссылки на проекты и связанные с ними объекты и если передать тот же самый хидер в VBDllGetClassObject, то рантайм проверит, не загружался ли такой проект, и если загружался, то просто запустит новую копию без разбора структуры vbHeader, на основании предыдущего разбора. Поэтому я решил поступить так - можно скопировать структуру vbHeader в другое место и использовать ее. Сразу замечу, что в этой структуре последние 4 поля - это смещения относительно начала структуры, поэтому при копировании струкутуры их нужно будет скорректировать. Если теперь попробовать передать эту структуру в VBDllGetClassObject, то все будет отлично если в качестве стартапа установлена Sub Main, если же форма, то будет запущена и форма и после нее Main. Для исключения такого поведения нужно поправить кое-какие данные на которые ссылается хидер. Я пока точно не знаю что это за данные, т.к. не разбирался в этом, но "поковырявшись" внутри рантайма я нашел их место положение. Поле lpGuiTable структуры vbHeader ссылается на список структур tGuiTable, которые описывают формы в проекте. Структуры идут последовательно, число структур соответствует полю wFormCount структуры vbHeader. В сети я так и не нашел нормальное описание структуры tGuiTable, вот что есть:
    ExpandedWrap disabled
      Type tGuiTable
          lStructSize          As Long
          uuidObjectGUI        As uuid
          Unknown1             As Long
          Unknown2             As Long
          Unknown3             As Long
          Unknown4             As Long
          lObjectID            As Long
          Unknown5             As Long
          fOLEMisc             As Long
          uuidObject           As uuid
          Unknown6             As Long
          Unknown7             As Long
          aFormPointer         As Long
          Unknown8             As Long
      End Type

    Как выяснилось внутри рантайма есть код, который проверяет поле Unknown5 каждой структуры:
    user posted image

    Я проставил комментарии; из них видно что Unknown5 содержит флаги и если установлен 5-й бит, то происходит запись ссылки на какой-то объект, заданный регистром EAX, в поле со смещением 0x30 объекта заданного регистром EDX. Что за объекты - я не знаю, возможно позже разберусь с этим, нам важен сам факт записи какого-то значения в поле со смещением 0x30. Теперь, если дальше начать исследовать код то можно наткнутся на такой фрагмент:
    user posted image

    Скажу что объект на который указывает ESI, тот же самый объект что в предыдущей рассматриваемой процедуре (регистр EDX). Видно что тестируется значение этого поля на -1 и на 0, и если там любое из этих чисел то запускается процедура Main (если она задана); иначе запускается первая форма.
    Итак, теперь чтобы гарантированно запускать только Sub Main, мы изменяем флаг lpGuiTable.Unknown5, сбрасывая пятый бит. Для установки новой Sub Main и модификации флага я создал отдельную процедуру:
    ExpandedWrap disabled
      ' // Modify VBHeader to replace Sub Main
      Private Sub ModifyVBHeader(ByVal newAddress As Long)
          Dim ptr     As Long
          Dim old     As Long
          Dim flag    As Long
          Dim count   As Long
          Dim size    As Long
          
          ptr = lpVBHeader + &H2C
          ' Are allowed to write in the page
          VirtualProtect ByVal ptr, 4, PAGE_READWRITE, old
          ' Set a new address of Sub Main
          GetMem4 newAddress, ByVal ptr
          VirtualProtect ByVal ptr, 4, old, 0
          
          ' Remove startup form
          GetMem4 ByVal lpVBHeader + &H4C, ptr
          ' Get forms count
          GetMem4 ByVal lpVBHeader + &H44, count
          
          Do While count > 0
              ' Get structure size
              GetMem4 ByVal ptr, size
              ' Get flag (unknown5) from current form
              GetMem4 ByVal ptr + &H28, flag
              ' When set, bit 5,
              If flag And &H10 Then
                  ' Unset bit 5
                  flag = flag And &HFFFFFFEF
                  ' Are allowed to write in the page
                  VirtualProtect ByVal ptr, 4, PAGE_READWRITE, old
                  ' Write changet flag
                  GetMem4 flag, ByVal ptr + &H28
                  ' Restoring the memory attributes
                  VirtualProtect ByVal ptr, 4, old, 0
                  
              End If
              count = count - 1
              ptr = ptr + size
              
          Loop
          
      End Sub

    Теперь, если попробовать запустить эту процедуру перед передачей хидера в VBDllGetClassObject, то будет запускаться процедура, определенная нами. Впрочем многопоточность уже будет работать, но это не удобно, т.к. отсутствует механизм передачи параметра в поток как это реализовано в CreateThread. Для того чтобы сделать полный аналог CreateThread я решил создать аналогичную функцию, которая будет проводить все инициализации и после выполнять вызов переданной функции потока вместе с параметром. Для того чтобы была возможность передать параметр в Sub Main, я использовал локальное хранилище потока (TLS). Мы выделяем индекс для TLS. После выделения индекса мы сможем задавать значение этого индекса, специфичное для каждого потока. В общем идея такова, создаем новый поток, где стартовой функцией будет специальная функция ThreadProc, в параметр которой передаем структуру из двух полей - адреса пользовательской функции и адреса параметра. В этой процедуре мы будем инициализировать рантайм для нового потока и сохранять в TLS переданный параметр. В качестве процедуры Main создадим бинарный код, который будет доставать данные из TLS, формировать стек и прыгать на пользовательскую функцию. В итоге получился такой модуль:
    modMultiThreading.bas
    ExpandedWrap disabled
      ' modMultiThreading.bas - The module provides support for multi-threading.
      ' © Кривоус Анатолий Анатольевич (The trick), 2015
       
      Option Explicit
       
      Private Type uuid
          data1       As Long
          data2       As Integer
          data3       As Integer
          data4(7)    As Byte
      End Type
       
      Private Type threadData
          lpParameter As Long
          lpAddress   As Long
      End Type
       
      Private tlsIndex    As Long  ' Index of the item in the TLS. There will be data specific to the thread.
      Private lpVBHeader  As Long  ' Pointer to VBHeader structure.
      Private hModule     As Long  ' Base address.
      Private lpAsm       As Long  ' Pointer to a binary code.
       
      ' // Create a new thread
      Public Function vbCreateThread(ByVal lpThreadAttributes As Long, _
                                     ByVal dwStackSize As Long, _
                                     ByVal lpStartAddress As Long, _
                                     ByVal lpParameter As Long, _
                                     ByVal dwCreationFlags As Long, _
                                     lpThreadId As Long) As Long
          Dim InIDE   As Boolean
          
          Debug.Assert MakeTrue(InIDE)
          
          If InIDE Then
              Dim ret As Long
              
              ret = MsgBox("Multithreading not working in IDE." & vbNewLine & "Run it in the same thread?", vbQuestion Or vbYesNo)
              If ret = vbYes Then
                  ' Run function in main thread
                  ret = DispCallFunc(ByVal 0&, lpStartAddress, CC_STDCALL, vbEmpty, 1, vbLong, VarPtr(CVar(lpParameter)), CVar(0))
                  If ret Then
                      Err.Raise ret
                  End If
              End If
              
              Exit Function
          End If
          
          ' Alloc new index from thread local storage
          If tlsIndex = 0 Then
              
              tlsIndex = TlsAlloc()
              
              If tlsIndex = 0 Then Exit Function
              
          End If
          ' Get module handle
          If hModule = 0 Then
              
              hModule = GetModuleHandle(ByVal 0&)
              
          End If
          ' Create assembler code
          If lpAsm = 0 Then
              
              lpAsm = CreateAsm()
              If lpAsm = 0 Then Exit Function
              
          End If
          ' Get pointer to VBHeader and modify
          If lpVBHeader = 0 Then
          
              lpVBHeader = GetVBHeader()
              If lpVBHeader = 0 Then Exit Function
              
              ModifyVBHeader lpAsm
              
          End If
          
          Dim lpThreadData    As Long
          Dim tmpData         As threadData
          ' Alloc thread-specific memory for threadData structure
          lpThreadData = HeapAlloc(GetProcessHeap(), 0, Len(tmpData))
          
          If lpThreadData = 0 Then Exit Function
          ' Set parameters
          tmpData.lpAddress = lpStartAddress
          tmpData.lpParameter = lpParameter
          ' Copy parameters to thread-specific memory
          GetMem8 tmpData, ByVal lpThreadData
          ' Create thread
          vbCreateThread = CreateThread(ByVal lpThreadAttributes, _
                                        dwStackSize, _
                                        AddressOf ThreadProc, _
                                        ByVal lpThreadData, _
                                        dwCreationFlags, _
                                        lpThreadId)
          
      End Function
       
      ' // Initialize runtime for new thread and run procedure
      Private Function ThreadProc(lpParameter As threadData) As Long
          Dim iid         As uuid
          Dim clsid       As uuid
          Dim lpNewHdr    As Long
          Dim hHeap       As Long
          ' Initialize COM
          vbCoInitialize ByVal 0&
          ' IID_IUnknown
          iid.data4(0) = &HC0: iid.data4(7) = &H46
          ' Store parameter to thread local storage
          TlsSetValue tlsIndex, lpParameter
          ' Create the copy of VBHeader
          hHeap = GetProcessHeap()
          lpNewHdr = HeapAlloc(hHeap, 0, &H6A)
          CopyMemory ByVal lpNewHdr, ByVal lpVBHeader, &H6A
          ' Adjust offsets
          Dim names()     As Long
          Dim diff        As Long
          Dim Index       As Long
          
          ReDim names(3)
          diff = lpNewHdr - lpVBHeader
          CopyMemory names(0), ByVal lpVBHeader + &H58, &H10
          
          For Index = 0 To 3
              names(Index) = names(Index) - diff
          Next
          
          CopyMemory ByVal lpNewHdr + &H58, names(0), &H10
          ' This line calls the binary code that runs the asm function.
          VBDllGetClassObject VarPtr(hModule), 0, lpNewHdr, clsid, iid, 0
          ' Free memeory
          HeapFree hHeap, 0, ByVal lpNewHdr
          HeapFree hHeap, 0, lpParameter
          
      End Function
       
      ' // Get VBHeader structure
      Private Function GetVBHeader() As Long
          Dim ptr     As Long
        
          ' Get e_lfanew
          GetMem4 ByVal hModule + &H3C, ptr
          ' Get AddressOfEntryPoint
          GetMem4 ByVal ptr + &H28 + hModule, ptr
          ' Get VBHeader
          GetMem4 ByVal ptr + hModule + 1, GetVBHeader
          
      End Function
       
      ' // Modify VBHeader to replace Sub Main
      Private Sub ModifyVBHeader(ByVal newAddress As Long)
          Dim ptr     As Long
          Dim old     As Long
          Dim flag    As Long
          Dim count   As Long
          Dim size    As Long
          
          ptr = lpVBHeader + &H2C
          ' Are allowed to write in the page
          VirtualProtect ByVal ptr, 4, PAGE_READWRITE, old
          ' Set a new address of Sub Main
          GetMem4 newAddress, ByVal ptr
          VirtualProtect ByVal ptr, 4, old, 0
          
          ' Remove startup form
          GetMem4 ByVal lpVBHeader + &H4C, ptr
          ' Get forms count
          GetMem2 ByVal lpVBHeader + &H44, count
          
          Do While count > 0
              ' Get structure size
              GetMem4 ByVal ptr, size
              ' Get flag (unknown5) from current form
              GetMem4 ByVal ptr + &H28, flag
              ' When set, bit 5,
              If flag And &H10 Then
                  ' Unset bit 5
                  flag = flag And &HFFFFFFEF
                  ' Are allowed to write in the page
                  VirtualProtect ByVal ptr, 4, PAGE_READWRITE, old
                  ' Write changet flag
                  GetMem4 flag, ByVal ptr + &H28
                  ' Restoring the memory attributes
                  VirtualProtect ByVal ptr, 4, old, 0
                  
              End If
              
              count = count - 1
              ptr = ptr + size
              
          Loop
          
      End Sub
       
      ' // Create binary code.
      Private Function CreateAsm() As Long
          Dim hMod    As Long
          Dim lpProc  As Long
          Dim ptr     As Long
          
          hMod = GetModuleHandle(ByVal StrPtr("kernel32"))
          lpProc = GetProcAddress(hMod, "TlsGetValue")
          
          If lpProc = 0 Then Exit Function
          
          ptr = VirtualAlloc(ByVal 0&, &HF, MEM_RESERVE Or MEM_COMMIT, PAGE_EXECUTE_READWRITE)
          
          If ptr = 0 Then Exit Function
          
          ' push  tlsIndex
          ' call  TLSGetValue
          ' pop   ecx
          ' push  DWORD [eax]
          ' push  ecx
          ' jmp   DWORD [eax + 4]
          
          GetMem4 &H68, ByVal ptr + &H0:          GetMem4 &HE800, ByVal ptr + &H4
          GetMem4 &HFF590000, ByVal ptr + &H8:    GetMem4 &H60FF5130, ByVal ptr + &HC
          GetMem4 &H4, ByVal ptr + &H10:          GetMem4 tlsIndex, ByVal ptr + 1
          GetMem4 lpProc - ptr - 10, ByVal ptr + 6
          
          CreateAsm = ptr
          
      End Function
       
      Private Function MakeTrue(value As Boolean) As Boolean
          MakeTrue = True: value = True
      End Function

    Все API декларации я сделал в отдельной библиотеке типов - EXEInitialize.tlb. Пока найден один недостаток - не работают формы с приватными контролами, если разберусь в чем причина - исправлю. Работает только в скомпилированном варианте.

    В архиве содержится несколько тестов.
    1-й: создание формы в новом потоке, с возможностью блокировки ввода посредством длинного цикла.
    2-й: обработка событий от объекта, метод которого вызван в другом потоке. Сразу скажу так делать нельзя и неправильно, т.к. передавать между потоками ссылку без маршаллинга опасно и может привести к глюкам, к тому же обработка события выполняется в другом потоке. Этот пример я оставил в качестве демонстрации работы многопоточности, а не для использования в повседневных задачах.
    3-й: демонстрация изменения значения общей переменной в одном потоке и считывание его из другого.
    Видео.

    Скачать метериалы.

    Всем удачи!
    Сообщение отредактировано: TheTrik -
    0 пользователей читают эту тему (0 гостей и 0 скрытых пользователей)
    0 пользователей:


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