Многопоточность в VB6 часть 2 - создание Native DLL и вызов экспортируемой функции в другом потоке.

' 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 '

Public Function DllMain(ByVal hInstDLL As Long, ByVal fdwReason As Long, ByVal lpvReserved As Long) As Long
 
End Function

' Код DLL
Dim Temp As Long
 
Public Sub foo()
    Temp = App.ThreadID
End Sub

' 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

' 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

[VBCompiler]
LinkSwitches= /ENTRY:DllMain /EXPORT:Brightness /EXPORT:Contrast /EXPORT:Saturation /EXPORT:GaussianBlur /EXPORT:EdgeDetect /EXPORT:Sharpen /EXPORT:Emboss /EXPORT:Minimum /EXPORT:Maximum /EXPORT:FishEye

' Демонстрация использования многопоточности в 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                                 '   |
' // ---------------------------------------+