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