На главную Наши проекты:
Журнал   ·   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 часть 2 , Создание Native DLL и вызов экспортируемой функции в другом потоке.
TheTrik
Сообщ. #1 ,
    Full Member
    ***
    Профиль · PM
    Поощрения: 10 Dgm
    Рейтинг (т): 29
    Сегодня я расскажу о еще одном методе написания многопоточных программ на VB6, а именно создание потока в Native DLL. В принципе здесь нет ничего сложного, передаем в CreateThread адрес экспортируемой функции и она будет исполнена в другом потоке. Все бы хорошо, но стандартными, документированными возможностями VB6 не позволяет создавать нативные DLL. Но не все так плохо, есть несколько приемов, с помощью которых можно создать нативную DLL, начиная от подмены линкера, FNDLL и заканчивая недокументированными секциями в 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 - "Рыбий глаз"
    ExpandedWrap disabled
      ' modEffects.bas  - функции для обработки изображений
      ' © Кривоус Анатолий Анатольевич (The trick), 2014
       
      Option Explicit
       
      ' Передаем эту структуру в поток
      Private Type ThreadData
          pix()       As Byte     ' Двухмерный массив пикселей рисунка (w-1,h-1)
          value       As Single   ' Значение эффекта
          percent     As Single   ' Процент выполнения 0..1
      End Type
       
      ' // Функция изменения яркости
      Public Function Brightness(dat As ThreadData) As Long
          Dim col()   As Byte
          Dim x       As Long
          Dim y       As Long
          Dim tmp     As Long
          Dim value   As Single
          
          On Error GoTo ERRORLABEL
          
          value = dat.value
          If value < -1 Then value = -1
          If value > 1 Then value = 1
          
          ReDim col(255)
          
          For x = 0 To 255
              tmp = x + value * 255
              If tmp > 255 Then tmp = 255 Else If tmp < 0 Then tmp = 0
              col(x) = tmp
          Next
          
          For y = 0 To UBound(dat.pix, 2)
              For x = 0 To UBound(dat.pix, 1)
                  dat.pix(x, y) = col(dat.pix(x, y))
              Next
              dat.percent = y / UBound(dat.pix, 2)
          Next
       
          dat.percent = 1
          Brightness = 1
          
      ERRORLABEL:
       
      End Function
       
      ' // Функция изменения контрастности
      Public Function Contrast(dat As ThreadData) As Long
          Dim col()   As Byte
          Dim x       As Long
          Dim y       As Long
          Dim tmp     As Long
          Dim value   As Single
          
          On Error GoTo ERRORLABEL
          
          value = dat.value
          If value < 0 Then value = 0
          If value > 100 Then value = 100
          
          ReDim col(255)
          
          For x = 0 To 255
              tmp = 128 + (value ^ 3) * (x - 128)
              If tmp > 255 Then tmp = 255 Else If tmp < 0 Then tmp = 0
              col(x) = tmp
          Next
          
          For y = 0 To UBound(dat.pix, 2)
              For x = 0 To UBound(dat.pix, 1)
                  dat.pix(x, y) = col(dat.pix(x, y))
              Next
              dat.percent = y / UBound(dat.pix, 2)
          Next
       
          dat.percent = 1
          Contrast = 1
          
      ERRORLABEL:
       
      End Function
       
      ' // Функция изменения насыщенности
      Public Function Saturation(dat As ThreadData) As Long
          Dim x       As Long
          Dim y       As Long
          Dim w       As Long
          Dim h       As Long
          Dim tmp     As Long
          Dim r       As Long
          Dim g       As Long
          Dim b       As Long
          Dim br      As Long
          Dim value   As Single
          
          On Error GoTo ERRORLABEL
          
          value = dat.value
          If value > 1 Then value = 1
          If value < 0 Then value = 0
          
          w = UBound(dat.pix, 1) \ 4
          h = UBound(dat.pix, 2)
          
          For y = 0 To h
              For x = 0 To w
                  b = dat.pix(x * 4, y)
                  g = dat.pix(x * 4 + 1, y)
                  r = dat.pix(x * 4 + 2, y)
                  br = 0.3 * r + 0.59 * g + 0.11 * b
                  r = r * value + br * (1 - value)
                  g = g * value + br * (1 - value)
                  b = b * value + br * (1 - value)
                  dat.pix(x * 4, y) = b
                  dat.pix(x * 4 + 1, y) = g
                  dat.pix(x * 4 + 2, y) = r
              Next
              dat.percent = y / h
          Next
       
          dat.percent = 1
          Saturation = 1
          
      ERRORLABEL:
       
      End Function
       
      ' // Функция размытия по Гауссу
      Public Function GaussianBlur(dat As ThreadData) As Long
          Dim kernel()    As Single
          Dim size        As Long
          Dim half        As Long
          Dim weight      As Long
          Dim gx          As Single
          Dim tmp()       As Byte
          Dim x           As Long
          Dim y           As Long
          Dim w           As Long
          Dim h           As Long
          Dim index       As Long
          Dim acc         As Long
          Dim wFrom       As Long
          Dim wTo         As Long
          Dim norm()      As Single
          Dim lnorm       As Single
          Dim px          As Long
          Dim value       As Single
          
          On Error GoTo ERRORLABEL
          
          value = dat.value
          If value < 0 Then value = 0
          If value > 255 Then value = 255
          
          size = CLng(value) * 2
          half = -Int(-size / 2)
          ReDim kernel(size)
          
          kernel(half) = 1
          ReDim norm(half)
          lnorm = 1
          For weight = 1 To half
              gx = 3 * weight / half
              kernel(half - weight) = Exp(-gx * gx / 2)
              kernel(half + weight) = kernel(half - weight)
              lnorm = lnorm + kernel(half + weight) * 2
          Next
          
          For x = 0 To half
              norm(x) = lnorm
              lnorm = lnorm - kernel(x)
          Next
          
          w = UBound(dat.pix, 1) \ 4
          h = UBound(dat.pix, 2)
          ReDim tmp(w * 4, h)
       
          For y = 0 To h
              For x = 0 To w - 1
                  If x < half Then wFrom = x Else wFrom = half
                  If x > w - half Then wTo = w - x Else wTo = half
                  
                  For px = 0 To 3
                      acc = 0
                      For index = -wFrom To wTo
                          acc = acc + dat.pix((x + index) * 4 + px, y) * kernel(index + half)
                      Next
                      acc = acc / norm(half * 2 - (wTo + wFrom))
                      If acc > 255 Then acc = 255
                      tmp(x * 4 + px, y) = acc
                  Next
              Next
              dat.percent = y / h / 2
          Next
          
          For x = 0 To w - 1
              For y = 0 To h
                  If y < half Then wFrom = y Else wFrom = half
                  If y > h - half Then wTo = h - y Else wTo = half
                  For px = 0 To 4
                      acc = 0
                      For index = -wFrom To wTo
                          acc = acc + tmp(x * 4 + px, y + index) * kernel(index + half)
                      Next
                      acc = acc / norm(half * 2 - (wTo + wFrom))
                      If acc > 255 Then acc = 255
                      dat.pix(x * 4 + px, y) = acc
                  Next
              Next
              dat.percent = x / w / 2 + 0.5
          Next
          
          dat.percent = 1
          GaussianBlur = 1
          
      ERRORLABEL:
          
      End Function
       
      ' // Минимум
      Public Function Minimum(dat As ThreadData) As Long
          Dim x       As Long
          Dim y       As Long
          Dim w       As Long
          Dim h       As Long
          Dim px      As Long
          Dim hlf     As Long
          Dim fx      As Long
          Dim fy      As Long
          Dim tx      As Long
          Dim ty      As Long
          Dim dx      As Long
          Dim dy      As Long
          Dim acc     As Byte
          Dim tmp()   As Byte
          Dim value   As Single
          
          On Error GoTo ERRORLABEL
          
          value = dat.value
          If value < 0 Then value = 0
          If value > 255 Then value = 255
          
          w = UBound(dat.pix, 1) \ 4
          h = UBound(dat.pix, 2)
          hlf = CLng(dat.value)
          tmp = dat.pix
          
          For y = 0 To h
          
              If y < hlf Then fy = y Else fy = hlf
              If y > h - hlf Then ty = h - y Else ty = hlf
              
              For x = 0 To w
              
                  If x < hlf Then fx = x Else fx = hlf
                  If x > w - hlf Then tx = w - x Else tx = hlf
                  
                  For px = 0 To 3
                      acc = 255
                      
                      For dx = -fx To tx: For dy = -fy To ty
                          If tmp((x + dx) * 4 + px, y + dy) < acc Then acc = tmp((x + dx) * 4 + px, y + dy)
                      Next: Next
                      
                      dat.pix(x * 4 + px, y) = acc
                      
                  Next
                  
              Next
              
              dat.percent = y / h
              
          Next
          
          dat.percent = 1
          Minimum = 1
          
      ERRORLABEL:
          
      End Function
       
      ' // Максимум
      Public Function Maximum(dat As ThreadData) As Long
          Dim x       As Long
          Dim y       As Long
          Dim w       As Long
          Dim h       As Long
          Dim px      As Long
          Dim hlf     As Long
          Dim fx      As Long
          Dim fy      As Long
          Dim tx      As Long
          Dim ty      As Long
          Dim dx      As Long
          Dim dy      As Long
          Dim acc     As Byte
          Dim tmp()   As Byte
          Dim value   As Single
          
          On Error GoTo ERRORLABEL
          
          value = dat.value
          If value < 0 Then value = 0
          If value > 255 Then value = 255
       
          w = UBound(dat.pix, 1) \ 4
          h = UBound(dat.pix, 2)
          hlf = CLng(dat.value)
          tmp = dat.pix
          
          For y = 0 To h
          
              If y < hlf Then fy = y Else fy = hlf
              If y > h - hlf Then ty = h - y Else ty = hlf
              
              For x = 0 To w
              
                  If x < hlf Then fx = x Else fx = hlf
                  If x > w - hlf Then tx = w - x Else tx = hlf
                  
                  For px = 0 To 3
                      acc = 0
                      
                      For dx = -fx To tx: For dy = -fy To ty
                          If tmp((x + dx) * 4 + px, y + dy) > acc Then acc = tmp((x + dx) * 4 + px, y + dy)
                      Next: Next
                      
                      dat.pix(x * 4 + px, y) = acc
                      
                  Next
                  
              Next
              
              dat.percent = y / h
              
          Next
          
          dat.percent = 1
          Maximum = 1
          
      ERRORLABEL:
          
      End Function
       
      ' // Тиснение
      Public Function Emboss(dat As ThreadData) As Long
          Dim kernel()    As Single
          Dim value       As Single
          
          value = dat.value
          ReDim kernel(2, 2)
          
          kernel(0, 0) = -value ^ 2:  kernel(1, 0) = -value:          kernel(2, 0) = 0
          kernel(0, 1) = -value:      kernel(1, 1) = 9:               kernel(2, 1) = value
          kernel(0, 2) = 0:           kernel(1, 2) = value:           kernel(2, 2) = value ^ 2
          
          Emboss = Convolution(dat, kernel)
      End Function
       
      ' // Выделение краев
      Public Function EdgeDetect(dat As ThreadData) As Long
          Dim kernel() As Single
          Dim value       As Single
          
          value = dat.value
          ReDim kernel(2, 2)
          
          kernel(0, 0) = 0:           kernel(1, 0) = -value:          kernel(2, 0) = 0
          kernel(0, 1) = -value:      kernel(1, 1) = value * 4:       kernel(2, 1) = -value
          kernel(0, 2) = 0:           kernel(1, 2) = -value:          kernel(2, 2) = 0
          
          EdgeDetect = Convolution(dat, kernel)
       
      End Function
       
      ' // Резкость
      Public Function Sharpen(dat As ThreadData) As Long
          Dim kernel()    As Single
          Dim value       As Single
          
          value = dat.value
          ReDim kernel(2, 2)
          
          kernel(0, 0) = 0:           kernel(1, 0) = -value:          kernel(2, 0) = 0
          kernel(0, 1) = -value:      kernel(1, 1) = value * 4 + 9:   kernel(2, 1) = -value
          kernel(0, 2) = 0:           kernel(1, 2) = -value:          kernel(2, 2) = 0
          
          Sharpen = Convolution(dat, kernel)
       
      End Function
       
      ' // Рыбий глаз
      Public Function FishEye(dat As ThreadData) As Long
          Dim x       As Long
          Dim y       As Long
          Dim cx      As Single
          Dim cy      As Single
          Dim nx      As Long
          Dim ny      As Long
          Dim r       As Single
          Dim tmp()   As Byte
          Dim w       As Long
          Dim h       As Long
          Dim value   As Single
          Dim px      As Long
          
          On Error GoTo ERRORLABEL
          
          w = UBound(dat.pix, 1) \ 4 + 1
          h = UBound(dat.pix, 2) + 1
          value = dat.value
          
          If value > 1 Then value = 1
          If value < 0 Then value = 0
          
          tmp = dat.pix
          
          For y = 0 To h - 1
              For x = 0 To w - 1
                  cx = x / w - 0.5: cy = y / h - 0.5
                  r = Sqr(cx * cx + cy * cy)
                  nx = (cx + 0.5 + value * cx * ((r - 1) / 0.5)) * (w - 1)
                  ny = (cy + 0.5 + value * cy * ((r - 1) / 0.5)) * (h - 1)
                  For px = 0 To 3
                      dat.pix(x * 4 + px, y) = tmp(nx * 4 + px, ny)
                  Next
              Next
              dat.percent = y / h
          Next
          
          dat.percent = 1
          FishEye = 1
          
      ERRORLABEL:
      End Function
       
      ' // Фильтрация с помощью свертки
      Private Function Convolution(dat As ThreadData, kernel() As Single) As Long
          Dim x       As Long
          Dim y       As Long
          Dim w       As Long
          Dim h       As Long
          Dim dx      As Long
          Dim dy      As Long
          Dim tmp()   As Byte
          Dim valFx   As Long
          Dim valFy   As Long
          Dim valTx   As Long
          Dim valTy   As Long
          Dim acc     As Long
          Dim px      As Long
          Dim hlfSize As Long
          
          On Error GoTo ERRORLABEL
          
          w = UBound(dat.pix, 1)
          h = UBound(dat.pix, 2)
          hlfSize = UBound(kernel) \ 2
          
          tmp = dat.pix
          
          For y = 0 To h
              If y < hlfSize Then valFy = y Else valFy = hlfSize
              If y > h - hlfSize Then valTy = h - y Else valTy = hlfSize
              For x = 0 To w
                  px = x \ 4
                  If px < hlfSize Then valFx = px Else valFx = hlfSize
                  If px > w \ 4 - hlfSize Then valTx = w \ 4 - px Else valTx = hlfSize
                  acc = 0
                  For dy = -valFy To valTy
                      For dx = -valFx To valTx
                          acc = acc + tmp(x + dx * 4, y + dy) * kernel(dx + hlfSize, dy + hlfSize)
                      Next
                  Next
                  acc = acc \ ((valFx + valTx + 1) * (valFy + valTy + 1))
                  If acc > 255 Then acc = 255 Else If acc < 0 Then acc = 0
                  dat.pix(x, y) = acc
              Next
              dat.percent = y / h
          Next
          
          Convolution = 1
          dat.percent = 1
      ERRORLABEL:
          
      End Function '

    Все функции имеют один и тот же прототип для того чтобы можно было вызывать из в отдельно потоке, принимают структуру 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 стартует с нее. Прототип этой функции должен быть следующим:
    ExpandedWrap disabled
      Public Function DllMain(ByVal hInstDLL As Long, ByVal fdwReason As Long, ByVal lpvReserved As Long) As Long
      End Function

    В hInstDLL - передается базовый адрес загрузки модуля (он же hInstance, hModule), в fdwReason передается значение указывающее причину вызова этой функции. Существует 4 случая вызова этой функции, когда DLL загружается в адресное пространство процесса (DLL_PROCESS_ATTACH), когда создается новый поток в процессе (DLL_THREAD_ATTACH) и соответственно два парных противоположных случая при корректном завершении потока (DLL_THREAD_DETACH) и выгрузке DLL из памяти (DLL_PROCESS_DETACH), также корректном. lpReserved - нам не важен. Теперь при загрузке DLL будет вызываться наша функция и мы сможем делать инициализацию. С этим понятно. Теперь представим ситуацию, что DLL загрузилась в АП процесса, а процесс создал поток и оба вызвали функцию Foo, что будет? Какое значение будет иметь переменная Temp после окончания потоков?
    ExpandedWrap disabled
      ' Код DLL
      Dim Temp As Long
       
      Public Sub foo()
          Temp = App.ThreadID
      End Sub

    Все зависит от того, какой поток последним запишет значение в переменную Temp, а это нельзя знать точно. Возникла проблема - переменные уровня модуля стали разделяемыми, они доступны всем потокам процесса для модификации, а это может породить много ошибок (состояние гонки, блокировки и т.п.). К счастью есть выход из этой ситуации - использование локального хранилища потока (TLS) для хранения потокозависимых данных. Можно делать это вручную через специальные функции (TlsAlloc, TlsFree, TlsSetValue, TlsGetValue), либо поручить эту задачу компилятору, что более удобней. Для этого существует опция Threading model в свойствах проекта. Если там стоит Single Threaded, то все переменные будут общими, а если Apartment Threaded - то каждый поток получит свою копию переменных. С этим понятно. В нашем модуле нет общих переменных поэтому мы выбираем Single Threaded.
    Теперь по поводу инициализации рантайма. Методика инициализации рантайма для создания Native DLL, которая будет описана дальше, впервые была продемонстрирована и описана в проекте FireNativeDLL. Учитывая то, что ActiveX DLL работают в многопоточных программах (без труда можно работать с такой DLL например в Delphi или C++), то значит можно инициализировать поток пойдя методом создания объекта. После просмотра внутренностей ActiveX DLL, было выявлено что точка входа вызывает UserDllMain из рантайма, передавая первыми двумя параметрами два указателя:
    user posted image
    Итак, чтобы начать инициализацию нужно вызвать из нашей точки входа UserDllMain из VB6, но нужно достать 2 параметра. Пока мы этого делать не будем, т.к. одного вызова UserDllMain недостаточно, иначе можно было бы не заморачиваться а оставить как есть, она вызывается по умолчанию. Инициализация потока выполняется при создании объекта из ActiveX DLL. Для того чтобы создать объект нужно вызвать функцию DllGetClassObject из DLL. Давайте посмотрим как выглядит эта функция внутри, а заодно и другие экспортируемые функции:
    user posted image
    Функция DllGetClassObject пересылает данные в функцию VBDllGetClassObject из рантайма дополнительно передавая первыми тремя параметрами указатели. Видно что 2 указателя, передаваемые в UserDllMain первыми двумя параметрами, эквивалентны первым двум указателям передаваемым в VBDllGetClassObject, а третий параметр соответствует структуре VBHeader которая описывает проект. В моей версии рантайма первым параметром (lphInst) передается указатель в который UserDllMain записывает hInstance библиотеки, второй (lpUnk) параметр не используется ни одной функцией. Возможно что в каких-нибудь других версиях рантайма эти параметры будут использоваться по-другому, поэтому стоит передать правильные значения.
    Теперь нужно получить адреса этих данных. Для этого, анализируя опкоды, получаем их к примеру из DllGetClassObject:
    • Адрес VBHeader будет равен адресу функции DllGetClassObject + 2 (пропускаем опкод POP EAX, и PUSH)
    • Адрес lpUnk будет равен адресу функции DllGetClassObject + 7
    • Адрес lphInstance будет равен адресу функции DllGetClassObject + 12
    Получить адрес из UserDllMain очень просто, т.к. нам известен хендл библиотеки (он передается первым параметром); вызываем GetProcAddress и получаем адрес DllGetClassObject. Далее получаем значения через GetMem4. Хочу отметить что все API функции должны быть объявлены в библиотеке типов, для этого я скомпилировал DllInitialize.tlb, после компиляции она не нужна. Для вызова VBDllGetClassObject используем в качестве IID - IUnknown, в качестве CLSID - IID_NULL. Также для инициализации COM должна быть вызвана функция CoInitialize. Если теперь попробовать собрать DLL, то все будет работать, но нужно учитывать что при первом вызове VBDllGetClassObject все модульные переменные инициализируются значениями по умолчанию. Поэтому нужно полученные переменные до вызова сохранить в локальных переменных, а после уже можно сохранять в модульные. Также нужно учитывать потоковую модель проекта: для Apartment, в функции DllMain не должно быть обращений к модульным переменным. Для обеих моделей я создал 2 модуля:
    Для single threaded:
    ExpandedWrap disabled
      ' modMainDLL.bas  - инициализация DLL (Single thread)
      ' © Кривоус Анатолий Анатольевич (The trick), 2014
       
      Option Explicit
       
      Private Type uuid
          data1       As Long
          data2       As Integer
          data3       As Integer
          data4(7)    As Byte
      End Type
       
      Public hInstance    As Long
       
      Private lpInst_     As Long
      Private lpUnk_      As Long
      Private lpVBHdr_    As Long
       
      ' Точка входа
      Public Function DllMain(ByVal hInstDll As Long, ByVal fdwReason As Long, ByVal lpvReserved As Long) As Long
          Dim lpProc      As Long
          Dim lpInst      As Long
          Dim lpUnk       As Long
          Dim lpVBHdr     As Long
          
          ' При создании процесса инициализируем адреса нужных переменных
          If fdwReason = DLL_PROCESS_ATTACH Then
              ' Получаем нужные нам данные, VBHeader, и два указателя необходимых для инициализации
              lpProc = GetProcAddress(hInstDll, "DllGetClassObject")
              If lpProc = 0 Then Exit Function
              GetMem4 ByVal lpProc + 2, lpVBHdr
              GetMem4 ByVal lpProc + 7, lpUnk
              GetMem4 ByVal lpProc + 12, lpInst
              DllMain = InitRuntime(lpInst, lpUnk, lpVBHdr, hInstDll, fdwReason, lpvReserved)
              lpInst_ = lpInst: lpUnk_ = lpUnk: lpVBHdr_ = lpVBHdr: hInstance = hInstDll
          ElseIf fdwReason = DLL_THREAD_ATTACH Then
              DllMain = InitRuntime(lpInst_, lpUnk_, lpVBHdr_, hInstDll, fdwReason, lpvReserved)
          Else
              vbCoUninitialize
              DllMain = UserDllMain(lpInst_, lpUnk_, hInstDll, fdwReason, ByVal lpvReserved)
          End If
          
      End Function
       
      Private Function InitRuntime(ByVal lpInst As Long, ByVal lpUnk As Long, ByVal lpVBHdr As Long, ByVal hInstDll As Long, _
                                   ByVal fdwReason As Long, ByVal lpvReserved As Long) As Long
          Dim iid     As uuid
          Dim clsid   As uuid
          
          InitRuntime = UserDllMain(lpInst, lpUnk, hInstDll, fdwReason, ByVal lpvReserved)
          If InitRuntime Then
              vbCoInitialize ByVal 0&
              iid.data4(0) = &HC0: iid.data4(7) = &H46                    ' IUnknown
              VBDllGetClassObject lpInst, lpUnk, lpVBHdr, clsid, iid, 0   ' Инициализация потока
          End If
      End Function

    Для apartment threaded:
    ExpandedWrap disabled
      ' modMainDLL.bas  - инициализация DLL (Apartment threaded)
      ' © Кривоус Анатолий Анатольевич (The trick), 2014
       
      Option Explicit
       
      Private Type uuid
          data1       As Long
          data2       As Integer
          data3       As Integer
          data4(7)    As Byte
      End Type
       
      Public hInstance    As Long
       
      Private lpInst_     As Long
      Private lpUnk_      As Long
      Private lpVBHdr_    As Long
       
      ' Точка входа, здесь не должно быть обращения к внешним переменным, т.е. public, private, static
      Public Function DllMain(ByVal hInstDLL As Long, ByVal fdwReason As Long, ByVal lpvReserved As Long) As Long
          Dim iid         As uuid
          Dim clsid       As uuid
          Dim lpInst     As Long
          Dim lpUnk      As Long
          Dim lpVBHdr    As Long
          Dim lpProc  As Long
          
          ' При создании процесса или потока
          If fdwReason = DLL_PROCESS_ATTACH Or fdwReason = DLL_THREAD_ATTACH Then
              ' Получаем нужные нам данные, VBHeader, и два указателя необходимых для инициализаци
              ' Каждый поток содержит свои данные (публичные, статичные переменные и т.д.)
              lpProc = GetProcAddress(hInstDLL, "DllGetClassObject")
              If lpProc = 0 Then Exit Function
              GetMem4 ByVal lpProc + 2, lpVBHdr
              GetMem4 ByVal lpProc + 7, lpUnk
              GetMem4 ByVal lpProc + 12, lpInst
              ' Инициализация COM
              vbCoInitialize ByVal 0&
              ' Эта функция вызывается из ActiveX DLL
              DllMain = UserDllMain(lpInst, lpUnk, hInstDLL, fdwReason, ByVal lpvReserved)
              If DllMain = 0 Then Exit Function
              iid.data4(0) = &HC0: iid.data4(7) = &H46                            ' IUnknown
              VBDllGetClassObject lpInst, lpUnk, lpVBHdr, clsid, iid, 0           ' Инициализация потока
              ' Тут глобальные и статичные переменные обнуляются, восстанавливаем их
              SetPublicVariable lpInst, lpUnk, lpVBHdr, hInstDLL
          Else
              vbCoUninitialize
              DllMain = DefMainDLL(hInstDLL, fdwReason, ByVal lpvReserved)
          End If
       
      End Function
       
      Private Sub SetPublicVariable(ByVal lpInst As Long, ByVal lpUnk As Long, ByVal lpVBHdr As Long, ByVal hInstDLL As Long)
          lpInst_ = lpInst: lpUnk_ = lpUnk: lpVBHdr_ = lpVBHdr: hInstance = hInstDLL
      End Sub
      Private Function DefMainDLL(ByVal hInstDLL As Long, ByVal fdwReason As Long, ByVal lpvReserved As Long) As Long
          DefMainDLL = UserDllMain(lpInst_, lpUnk_, hInstDLL, fdwReason, ByVal lpvReserved)
      End Function

    Итак, теперь мы умеем инициализировать рантайм и можем приступить к компиляции нативной DLL. В файл проекта добавляем вот эти строки позволяющие указать дополнительные ключи компилятора и линкера:
    ExpandedWrap disabled
      [VBCompiler]
      LinkSwitches= /ENTRY:DllMain /EXPORT:Brightness /EXPORT:Contrast /EXPORT:Saturation /EXPORT:GaussianBlur /EXPORT:EdgeDetect /EXPORT:Sharpen /EXPORT:Emboss /EXPORT:Minimum /EXPORT:Maximum /EXPORT:FishEye

    И настраиваем потоковую модель проекта в single threaded, также нужно в проект добавить класс, иначе проект не скомпилируется. По желанию можно также добавить функциональность ActiveX DLL, тогда можно с этой DLL работать и как с ActiveX, и как с обычной нативной импортируя функции.
    Для тестирования DLL была написана мини-программа:
    ExpandedWrap disabled
      ' Демонстрация использования многопоточности в NativeDLL на примере графических эффектов
      ' © Кривоус Анатолий Анатольевич (The trick), 2014
       
      Option Explicit
       
      ' Структура, идентичная объявленной в DLL
      Private Type ThreadData
          pix()       As Byte
          value       As Single
          percent     As Single
      End Type
       
      Private Type BITMAPINFOHEADER
          biSize          As Long
          biWidth         As Long
          biHeight        As Long
          biPlanes        As Integer
          biBitCount      As Integer
          biCompression   As Long
          biSizeImage     As Long
          biXPelsPerMeter As Long
          biYPelsPerMeter As Long
          biClrUsed       As Long
          biClrImportant  As Long
      End Type
       
      Private Type BITMAPINFO
          bmiHeader       As BITMAPINFOHEADER
          bmiColors       As Long
      End Type
       
      Private Type OPENFILENAME
          lStructSize         As Long
          hwndOwner           As Long
          hInstance           As Long
          lpstrFilter         As Long
          lpstrCustomFilter   As Long
          nMaxCustFilter      As Long
          nFilterIndex        As Long
          lpstrFile           As Long
          nMaxFile            As Long
          lpstrFileTitle      As Long
          nMaxFileTitle       As Long
          lpstrInitialDir     As Long
          lpstrTitle          As Long
          Flags               As Long
          nFileOffset         As Integer
          nFileExtension      As Integer
          lpstrDefExt         As Long
          lCustData           As Long
          lpfnHook            As Long
          lpTemplateName      As Long
      End Type
       
      Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameW" (pOpenfilename As OPENFILENAME) As Long
      Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
      Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
      Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
      Private Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
      Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As Long) As Long
      Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
      Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
      Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
      Private Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, lpExitCode As Long) As Long
       
      Private Const STILL_ACTIVE  As Long = &H103&
      Private Const INFINITE      As Long = -1&
       
      Dim hLib    As Long         ' hInstance библиотеки
      Dim td      As ThreadData   ' Данные потока
      Dim hThread As Long         ' Описатель потока
      Dim pic     As StdPicture   ' Изображение
      Dim bi      As BITMAPINFO   ' Информация об изображении
      Dim quene   As Boolean      ' Флаг очереди
       
      ' // Нажатие на кнопку загрузки рисунка
      Private Sub cmdLoad_Click()
          ' Загружаем
          LoadImage
      End Sub
       
      ' // Загрузка формы
      Private Sub Form_Load()
          ' Загружаем DLL
          ChDir App.Path: ChDrive App.Path
          hLib = LoadLibrary(StrPtr("..\GraphicsDLL\GraphicsDLL.dll"))
          If hLib = 0 Then MsgBox "Неудалось загрузить DLL": End
          ' Загружаем картинку по умолчанию
          LoadImage "defpic.jpg"
      End Sub
       
      ' // Выгрузка формы
      Private Sub Form_Unload(cancel As Integer)
          ' Если поток выполняется ждем завершения
          If hThread Then WaitForSingleObject hThread, INFINITE
          ' Выгружаем библиотеку
          FreeLibrary hLib
      End Sub
       
      ' // Запускаем эффект
      Private Sub RunEffect()
          
          Select Case cboEffect.ListIndex
          Case 0: picImage.PaintPicture pic, 0, 0                 ' Исходное изображение
          Case 1: RunProcedure "Brightness", sldValue / 50 - 1    ' Яркость
          Case 2: RunProcedure "Contrast", sldValue / 50          ' Контрастность
          Case 3: RunProcedure "Saturation", sldValue / 100       ' Насыщенность
          Case 4: RunProcedure "GaussianBlur", sldValue / 2       ' Размытие
          Case 5: RunProcedure "EdgeDetect", sldValue / 2 + 1     ' Выделение контуров
          Case 6: RunProcedure "Sharpen", sldValue / 3            ' Резкость
          Case 7: RunProcedure "Emboss", sldValue / 10            ' Тиснение
          Case 8: RunProcedure "Minimum", sldValue / 10           ' Минимум
          Case 9: RunProcedure "Maximum", sldValue / 10           ' Максимум
          Case 10: RunProcedure "FishEye", sldValue / 100         ' Рыбий глаз
          End Select
          
      End Sub
       
      ' // Загрузить картинку
      Private Sub LoadImage(Optional ByVal fileName As String)
          Dim ofn     As OPENFILENAME
          Dim title   As String
          Dim out     As String
          Dim filter  As String
          Dim i       As Long
          Dim dx      As Long
          Dim dy      As Long
          ' Если поток выполняется ждем завершения
          If hThread Then WaitForSingleObject hThread, INFINITE
          ' Если имя файла не задано, то показываем диалог открытия файла
          If Len(fileName) = 0 Then
              ofn.nMaxFile = 260
              out = String(260, vbNullChar)
              title = "Open image"
              filter = "Picture file" & vbNullChar & "*.bmp;*.jpg" & vbNullChar
              ofn.hwndOwner = Me.hWnd
              ofn.lpstrTitle = StrPtr(title)
              ofn.lpstrFile = StrPtr(out)
              ofn.lStructSize = Len(ofn)
              ofn.lpstrFilter = StrPtr(filter)
              If GetOpenFileName(ofn) = 0 Then Exit Sub
              ' Получаем имя файла
              i = InStr(1, out, vbNullChar, vbBinaryCompare)
              fileName = Left$(out, i - 1)
          End If
          
          On Error Resume Next
          ' Загружаем картинку
          Set pic = LoadPicture(fileName)
          If Err.Number Then MsgBox "Ошибка загрузки изображения", vbCritical: Exit Sub
          On Error GoTo 0
          
          ' Установка постоянных атрибутов картинки
          bi.bmiHeader.biSize = Len(bi.bmiHeader)
          bi.bmiHeader.biBitCount = 32
          bi.bmiHeader.biHeight = ScaleY(pic.Height, vbHimetric, vbPixels)
          bi.bmiHeader.biWidth = ScaleX(pic.Width, vbHimetric, vbPixels)
          bi.bmiHeader.biPlanes = 1
          ' Массив пикселей
          ReDim td.pix(bi.bmiHeader.biWidth * 4 - 1, bi.bmiHeader.biHeight - 1)
          ' Проверка размеров
          If bi.bmiHeader.biWidth > picCanvas.ScaleWidth Then
              hsbScroll.Max = bi.bmiHeader.biWidth - picCanvas.ScaleWidth
              hsbScroll.Visible = True
              dx = -hsbScroll.value
          Else
              dx = (picCanvas.ScaleWidth - bi.bmiHeader.biWidth) / 2
              hsbScroll.value = 0: hsbScroll.Visible = False
          End If
          
          If bi.bmiHeader.biHeight > picCanvas.ScaleHeight Then
              vsbScroll.Max = bi.bmiHeader.biHeight - picCanvas.ScaleHeight
              vsbScroll.Visible = True
              dy = -vsbScroll.value
          Else
              dy = (picCanvas.ScaleHeight - bi.bmiHeader.biHeight) / 2
              vsbScroll.value = 0: vsbScroll.Visible = False
          End If
          ' Перемещаем картинку
          picImage.Move dx, dy, bi.bmiHeader.biWidth, bi.bmiHeader.biHeight
          ' Отображаем ее
          cboEffect.ListIndex = 0: RunEffect
      End Sub
       
      ' // Запустить эффект в другом потоке
      Private Sub RunProcedure(Name As String, ByVal value As Single)
          Dim lpProc As Long
          ' Если в очереди уже есть вызов выходим
          If quene Then Exit Sub
          ' Если поток активен, то ставим в очередь текущий вызов и выходим
          If hThread Then quene = True: Exit Sub
          ' Получаем адрес функции
          lpProc = GetProcAddress(hLib, Name)
          If lpProc = 0 Then MsgBox "Невозможно найти функцию": Exit Sub
          ' Устанавливаем значение эффекта
          td.value = value
          ' Получаем пиксели рисунка
          GetDIBits picCanvas.hdc, pic.Handle, 0, bi.bmiHeader.biHeight, td.pix(0, 0), bi, 0
          ' Создаем поток
          hThread = CreateThread(ByVal 0&, 0, lpProc, td, 0, 0)
          ' Включаем таймер прогрессбара
          tmrUpdate.Enabled = True
      End Sub
       
      ' // Изменение величины эффекта
      Private Sub sldValue_Change()
          RunEffect
      End Sub
       
      ' // Изменение типа эффекта
      Private Sub cboEffect_Click()
          RunEffect
      End Sub
       
      ' // Таймер обновления
      Private Sub tmrUpdate_Timer()
          Dim status  As Long
          ' Устанавливаем процент
          prgProgress.value = td.percent
          ' Получаем код завершения потока
          GetExitCodeThread hThread, status
          ' Если поток активен, выходим
          If status = STILL_ACTIVE Then Exit Sub
          ' Поток завершился, отключаем таймер
          tmrUpdate.Enabled = False
          If status Then
              ' Вызов удачен
              ' Обновляем изображение
              SetDIBitsToDevice picImage.hdc, 0, 0, bi.bmiHeader.biWidth, bi.bmiHeader.biHeight, 0, 0, 0, bi.bmiHeader.biHeight, td.pix(0, 0), bi, 0
              picImage.Refresh
          Else
              ' При неудаче (функция эффекта возвратила 0)
              MsgBox "Функция потерпела неудачу", vbExclamation
          End If
          ' Закрываем описатель
          CloseHandle hThread
          ' Поток завершен
          hThread = 0
          ' Если в очереди был вызов, то вызываем
          If quene Then quene = False: RunEffect
      End Sub
       
      ' // Скроллбары ----------------------------+
      Private Sub vsbScroll_Change()          '   |
          picImage.Top = -vsbScroll.value     '   |
      End Sub                                 '   |
      Private Sub vsbScroll_Scroll()          '   |
          vsbScroll_Change                    '   |
      End Sub                                 '   |
      Private Sub hsbScroll_Change()          '   |
          picImage.Left = -hsbScroll.value    '   |
      End Sub                                 '   |
      Private Sub hsbScroll_Scroll()          '   |
          hsbScroll_Change                    '   |
      End Sub                                 '   |
      ' // ---------------------------------------+

    Программа достаточно простая, все действия прокомментированы. Основные моменты я дополнительно поясню. При загрузке формы загружается наша DLL, и хендл библиотеки сохраняется в переменной hLib. Далее загружается изображение по умолчанию, расположенное в папке проекта. В процедуре загрузки изображения (LoadImage), заполняются основные поля структуры BITMAPINFO и выделяется массив под пиксели рисунка, для того чтобы потом можно было получить их через GetDiBits. Процедура RunEffect запускает функцию из DLL в отдельном потоке (RunProcedure). Для исключения запуска нескольких потоков в процедуре RunProcedure стоит проверка, если поток запущен, то установить переменную флаг (quene) и выйти не запуская ничего. Если поток не запущен, то получить пиксели через GetDiBits, и подготовив данные для потока (td), запустить функцию в отдельном потоке. Также при создании включается таймер обновления состояния. В процедуре таймера обновляется состояние прогрессбара исходя из значения переменной td.percent, и если поток успешно закончил свое выполнение (функция вернула не 0) обновляем данные в пикчербоксе через SetDIBitsToDevice. При окончании, если в переменной quene было True, то запускаем эффект, это позволит изменять значение величины эффекта или сам эффект пока идет обработка.
    user posted image

    Как видно из примера многопоточность отлично работает в VB6. К тому же эту DLL можно использовать в любом ЯП. В следующей части я опишу пример внедрения DLL и переопределение оконной процедуры, что даст возможность отслеживать различные события в других приложениях, перехватывать API функции и многое другое.

    Все вышеописанное является моим личным исследованием и поэтому могут быть любые "подводные камни", о которых я не знаю. О любых багах можете сообщать мне, я постараюсь решить. Отдельную благодарность хотелось бы выразить Владиславу Петровскому (aka. Хакер), за открытие недокументированных ключей компилятора/компоновщика.
    Прикреплённый файлПрикреплённый файлGraphicsNativeDLL.rar (93,04 Кбайт, скачиваний: 187)
    Сообщение отредактировано: TheTrik -
    1 пользователей читают эту тему (1 гостей и 0 скрытых пользователей)
    0 пользователей:


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