Quantcast
Channel: VBForums - CodeBank - Visual Basic 6 and earlier
Viewing all 1304 articles
Browse latest View live

[VB6] - Hash-table

0
0
Represent a standalone class implements a hash table, which in many cases can be a substitute for the dictionary (Dictionary) of Scripting runtime. Implements all the same methods as in the dictionary, and add new ones. Includes support transfer through the For Each, you can also set the mode of transfer of keys/values, as compared to the previous version fixes bugs departure from the environment during your stay in the loop For Each, and there are no restrictions on the nested loops. Run fast enough on my computer about as well (even a bit faster) as a dictionary with binary comparison, when the text comparison works almost 2 times faster than the dictionary. As keys are allowed Variant variables with types of vbEmpty to vbDecimal inclusive. Numeric keys must be unique, ie -1, True, -1e0 - the same key as in the dictionary. New method EnumMode - determines the current mode of transfer. Valid values ENUM_BY_KEY, ENUM_BY_VALUE. Upon entering the For Each loop starts listing the parameter that is set this property. For example, you can list the keys in the main loop, the attached values or keys first and then the value. Also setting this property in windows Locals or Watch You can toggle the display with keys to values and vice versa.
Implementation itself is an array of doubly-linked lists, where the array indexes - the hash values of the corresponding keys. To support enumeration is used enumerator object. Implementing an interface IEnumVariant and IUnknown for the enumerator is written in assembly language:
Code:

[BITS 32]

QueryInterface:
    mov eax,[esp+4]        ; ObjPtr
    inc dword [eax+4]      ; Counter++
    mov ecx, [esp+0xc]
    mov [ecx],eax          ; ppvObject = ObjPtr
    xor eax,eax            ; Success
    ret 0xc

AddRef:
    mov eax,[esp+4]        ; ObjPtr
    inc dword [eax+4]      ; Counter++
    mov eax, [eax+4]        ; Counter return
    ret 0x4

Release:
    mov eax,[esp+4]        ; ObjPtr
    dec dword [eax+4]      ; Counter--
    jz  RemoveObject        ; if (Counter == 0)
    mov eax, [eax+4]        ; Counter return
    ret 0x4
RemoveObject:
    push    eax            ; lpMem
    push    0x00000001      ; HEAP_NO_SERIALIZE
    call    0x12345678      ; GetProcessHeap
    push    eax            ; hHeap
    call    0x12345678      ; HeapFree
    xor eax,eax            ; Counter = 0
    ret 0x4

IEnumVariant_Next:
    push ebx
    push edi
    push esi

    mov esi, [esp+0x10]    ; ObjPtr
    mov ebx, [esp+0x14]    ; ebx = celt
    mov edi, [esp+0x18]    ; rgVar

NextItem:

        movsx  eax, word [esi+0x8] ; Pointer.Hash
        inc eax
        jz  ExitCycle          ; if (Pointer.Hash == -1)
        dec eax
        mov ecx, [esi+0xc]      ; DataPtr
        mov ecx, [ecx+eax*8+4]  ; ecx = tItem.tElement
        movzx  eax, word [esi+0xA] ; Pointer.Index
        imul    ax, ax, 0x28        ;
        movzx  eax, ax        ; eax = Pointer.Index * sizeof(tElement)
        mov ecx, [ecx+0xc]      ; ecx = *tElement(0)
        lea ecx, [ecx+eax]      ; *tElement(Pointer.Index)
        mov eax, [ecx+0x20]
        add ecx, [esi+0x14]    ; ecx += OffsetVarinat
        mov [esi+0x8], eax      ; Pointer = tElement(Pointer.Index).Next
        push    ecx            ; pvargSrc
        push    edi            ; pvargDest == rgVar
        call    0x12345678      ; VariantCopy

        add edi, 0x10
        dec ebx
        jne NextItem
       
ExitCycle:
   
    test ebx, ebx
    setne  dl              ; if (ebx = 0) dl = 0 else dl = 1
    movzx  esi, dl        ; edx = dl
   
    mov edi, [esp+0x1c]    ; pCeltFetched
    test edi, edi
    je ExitFunction
   
    mov eax, [esp+0x14]    ; eax = celt
    sub eax, ebx
    mov    [edi], eax      ; pCeltFetched = count

ExitFunction:
   
    mov eax, esi
    pop esi
    pop edi
    pop ebx
    ret 0x10

IEnumVariant_Skip:

    mov edx, [esp+0x04]    ; ObjPtr
    mov eax, [edx+0x8]      ; Pointer.Hash
    mov edx, [edx+0xc]      ; DataPtr

NextItem_2:
       
        inc ax
        jz  ExitCycle_2        ; if (Pointer.Hash == -1)
        dec ax
       
        movzx  ecx, ax        ; ecx = Pointer.Hash
        mov ecx, [edx+ecx*8+4]  ; ecx = tItem.tElement
        shr eax, 0x10          ; eax = Pointer.Index
        imul    ax, ax, 0x28    ;

        mov ecx, [ecx+0xc]      ; ecx = *tElement(0)
        mov eax, [ecx+eax+0x20] ; eax = tElement(Pointer.Index).Next
       
        dec dword [esp+0x08]    ; celt--
        jne NextItem_2
       
        xor edx, edx

ExitCycle_2:
   
    test edx, edx
    setne  dl              ; if (edx = 0) dl = 0 else dl = 1
    mov eax, edx
   
    ret 0x08

IEnumVariant_Reset:
    mov eax, [esp+0x04]    ; ObjPtr
    mov edx, [eax+0x10]    ; First
    mov [eax+0x08], edx    ; Pointer = First
    xor eax, eax
    ret 0x4

Code is generated only when the first object, and is used by all subsequent objects. The address is stored in the environment variable, as I did in subclassing.

[VB6] - Multithreading in VB6 Part 1

0
0
Hello everyone! Many people wonder multithreaded programs written in VB6. Write multithreaded programs in VB6 quite real, I have many examples that I also published in my blog, but there are restrictions, one way or another can be circumvented. I consider this question in this post will not, and will consider more correct (in terms of programming in VB6) method of of multithreading - using objects. In this method, there are no restrictions, unlike threading Standart EXE, and has all the advantages of OOP. Also, I hasten to note that the IDE is not intended for debugging multithreaded programs, so to debug such programs in the IDE will not work. For debugging I use another debugger. You can also debug streams separately, and then collect the EXE.
Using multiple threads, we have the ability to call methods asynchronously while maintaining synchronicity; ie we can call methods as well as in a separate thread, and in his. For example methods require large computational load should cause asynchronously and receive, at the end of the notice in the form of events. Such methods (properties) that work fast, you can call synchronously.
One of the problems create a thread on VB6 in Standart EXE, is the inability to use WinAPI calls functions through Declare. Unlike the functions declared in a type library and entering the import, Declared-function after each call to set the properties of the object variable Err.LastDllError. This is done by calling the function __vbaSetSystemError of MSVBVM. Object Err, is thread-dependent, and the reference to it is in the thread local storage (TLS). For each thread must create its own object Err, otherwise the function call __vbaSetSystemError, runtime inquiry link from the storage, and we have it is not there (or rather there is 0) and will read the wrong address, as a consequence of crash.
To prevent this behavior, you can declare a function in tlb, then the function will not be called __vbaSetSystemError. You can also initialize the Err object, create an object instance of the DLL in the new thread, then the runtime initializes the object itself. But to create a new object, you must first initialize the thread to work with COM, it needs to call CoInitialize (Ex), but we can not call functions. It is possible to declare a tlb (it only one), then all is fair; it can also be called from assembler code or in any other way. I always go to another. Why do I LastDllError? I can just simply call GetLastError himself when I need to. So I just find the address of the function __vbaSetSystemError and write the first instruction output from the procedure (ret). This is certainly not so nice, but reliably and quickly. You can have only one function CoInitialize, and then restore __vbaSetSystemError.
Now we can call Declared-function in a new thread, which gives us endless possibilities. After creating the object (CreateObject), we can call its methods, properties, events receive from him, etc., but just a link between streams can not be passed because errors can occur because of concurrent access to data, etc. To send a link exists between threads marshaling. We will use the universal marshaller, because we ActiveX DLL has a type library. The principle of work, I will not describe in detail, it has a lot of articles online. The general sense is that instead of a direct call to the object, the RPC request to another computer / process / thread. For processing queries need to use the message loop, and once it happened, then the communication between threads is done through the posts.
To test, I wrote a simple ActiveX DLL that lets you download a file from a network that has several methods and generates events.
Code:

' Класс MultithreadDownloader - класс загрузчика
' © Кривоус Анатолий Анатольевич (The trick), 2014
 
Option Explicit
 
Public Enum ErrorCodes
    OK
    NOT_INITIALIZE
    ERROR_CREATING_DST_FILE
End Enum
 
Private Declare Function InternetCloseHandle Lib "wininet" (ByRef hInternet As Long) As Boolean
Private Declare Function InternetOpen Lib "wininet" Alias "InternetOpenW" (ByVal lpszAgent As Long, ByVal dwAccessType As Long, ByVal lpszProxy As Long, ByVal lpszProxyBypass As Long, ByVal dwFlags As Long) As Long
Private Declare Function InternetOpenUrl Lib "wininet" Alias "InternetOpenUrlW" (ByVal hInternet As Long, ByVal lpszUrl As Long, ByVal lpszHeaders As Long, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByRef dwContext As Long) As Long
Private Declare Function InternetReadFile Lib "wininet" (ByVal hFile As Long, lpBuffer As Any, ByVal dwNumberOfBytesToRead As Long, ByRef lpdwNumberOfBytesRead As Long) As Integer
Private Declare Function HttpQueryInfo Lib "wininet" Alias "HttpQueryInfoW" (ByVal hRequest As Long, ByVal dwInfoLevel As Long, lpBuffer As Any, ByRef lpdwBufferLength As Long, ByRef lpdwIndex As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileW" (ByVal lpFileName As Long, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
 
Private Const INTERNET_OPEN_TYPE_PRECONFIG  As Long = 0
Private Const INTERNET_FLAG_RELOAD          As Long = &H80000000
Private Const HTTP_QUERY_CONTENT_LENGTH    As Long = 5
Private Const HTTP_QUERY_FLAG_NUMBER        As Long = &H20000000
Private Const CREATE_ALWAYS                As Long = 2
Private Const FILE_ATTRIBUTE_NORMAL        As Long = &H80
Private Const INVALID_HANDLE_VALUE          As Long = -1
Private Const GENERIC_WRITE                As Long = &H40000000
 
Public Event Complete()
Public Event Error(ByVal Code As Long)
Public Event Progress(ByVal Size As Currency, ByVal TotalSize As Currency, cancel As Boolean)
 
Private mBufferSize As Long
Private mError      As ErrorCodes
 
Dim hInternet  As Long
 
Public Property Get ErrorCode() As ErrorCodes
    ErrorCode = mError
End Property
 
Public Property Get BufferSize() As Long
    BufferSize = mBufferSize
End Property
Public Property Let BufferSize(ByVal Value As Long)
    If Value > &H1000000 Or Value < &H400 Then Err.Raise vbObjectError, "MultithreadDownloader", "Wrong buffer size": Exit Property
    mBufferSize = Value
End Property
 
Public Sub Download(URL As String, Filename As String)
    Dim hFile  As Long
    Dim hDst    As Long
    Dim fSize  As Currency
    Dim total  As Long
    Dim prgSize As Currency
    Dim cancel  As Boolean
    Dim buf()  As Byte
   
    If hInternet = 0 Then mError = NOT_INITIALIZE: RaiseEvent Error(mError): Exit Sub
    hFile = InternetOpenUrl(hInternet, StrPtr(URL), 0, 0, INTERNET_FLAG_RELOAD, 0)
   
    If hFile = 0 Then mError = Err.LastDllError: RaiseEvent Error(mError): Exit Sub
   
    If HttpQueryInfo(hFile, HTTP_QUERY_CONTENT_LENGTH Or HTTP_QUERY_FLAG_NUMBER, fSize, 8, 0) Then
        hDst = CreateFile(StrPtr(Filename), GENERIC_WRITE, 0, ByVal 0&, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
        If hDst = INVALID_HANDLE_VALUE Then mError = ERROR_CREATING_DST_FILE: RaiseEvent Error(mError): Exit Sub
        ReDim buf(mBufferSize - 1)
        Do
            If InternetReadFile(hFile, buf(0), mBufferSize, total) = 0 Then
                mError = Err.LastDllError
                RaiseEvent Error(mError)
                InternetCloseHandle hFile
                Exit Sub
            End If
            WriteFile hDst, buf(0), total, 0, ByVal 0&
            prgSize = prgSize + CCur(total) / 10000@
            RaiseEvent Progress(prgSize, fSize, cancel)
        Loop While (total = mBufferSize) And Not cancel
        CloseHandle hDst
        RaiseEvent Complete
    Else
        mError = Err.LastDllError
        RaiseEvent Error(mError)
    End If
    InternetCloseHandle hFile
    mError = OK
End Sub
 
Private Sub Class_Initialize()
    ' Инициализация WinInet
    hInternet = InternetOpen(StrPtr(App.ProductName), INTERNET_OPEN_TYPE_PRECONFIG, 0, 0, 0)
    mBufferSize = &H10000
End Sub
 
Private Sub Class_Terminate()
    ' Деинициализация
    If hInternet Then InternetCloseHandle hInternet
End Sub

The code basically simple, if you read the description of the API functions. When calling the method "Download", starts will download from time to time (depending on the size of the buffer) event is generated Progress. If an error occurs, an event "Error", and at the end of the "Complete". "BufferSize" - sets the size of the buffer, which is generated when filling event. Demo code and contains bugs.*
Class I named "MultithreadDownloader", and the library "MTDownloader", respectively ProgID of the object - "MTDownloader.MultithreadDownloader". After compiling obtain a description of the interfaces through OleView, PEExplorer etc. In my example, CLSID = {20FAEF52-0D1D-444B-BBAE-21240219905B}, IID = {DF3BDB52-3380-4B78-B691-4138300DD304}. I also put a check "RemoteServerFiles" to get the output type library for our DLL, and will connect it instead of DLL for guaranteed start of the application.

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

0
0

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 '

[VB6] - Multithreading in VB6 part 1

0
0
Hello everyone! Many people wonder multithreaded programs written in VB6. Write multithreaded programs in VB6 quite real, I have many examples that I also published in my blog, but there are restrictions, one way or another can be circumvented. I consider this question in this post will not, and will consider more correct (in terms of programming in VB6) method of of multithreading - using objects. In this method, there are no restrictions, unlike threading Standart EXE, and has all the advantages of OOP. Also, I hasten to note that the IDE is not intended for debugging multithreaded programs, so to debug such programs in the IDE will not work. For debugging I use another debugger. You can also debug streams separately, and then collect the EXE.
Using multiple threads, we have the ability to call methods asynchronously while maintaining synchronicity; ie we can call methods as well as in a separate thread, and in his. For example methods require large computational load should cause asynchronously and receive, at the end of the notice in the form of events. Such methods (properties) that work fast, you can call synchronously.
One of the problems create a thread on VB6 in Standart EXE, is the inability to use WinAPI calls functions through Declare. Unlike the functions declared in a type library and entering the import, Declared-function after each call to set the properties of the object variable Err.LastDllError. This is done by calling the function __vbaSetSystemError of MSVBVM. Object Err, is thread-dependent, and the reference to it is in the thread local storage (TLS). For each thread must create its own object Err, otherwise the function call __vbaSetSystemError, runtime inquiry link from the storage, and we have it is not there (or rather there is 0) and will read the wrong address, as a consequence of crash.
To prevent this behavior, you can declare a function in tlb, then the function will not be called __vbaSetSystemError. You can also initialize the Err object, create an object instance of the DLL in the new thread, then the runtime initializes the object itself. But to create a new object, you must first initialize the thread to work with COM, it needs to call CoInitialize (Ex), but we can not call functions. It is possible to declare a tlb (it only one), then all is fair; it can also be called from assembler code or in any other way. I always go to another. Why do I LastDllError? I can just simply call GetLastError himself when I need to. So I just find the address of the function __vbaSetSystemError and write the first instruction output from the procedure (ret). This is certainly not so nice, but reliably and quickly. You can have only one function CoInitialize, and then restore __vbaSetSystemError.
Now we can call Declared-function in a new thread, which gives us endless possibilities. After creating the object (CreateObject), we can call its methods, properties, events receive from him, etc., but just a link between streams can not be passed because errors can occur because of concurrent access to data, etc. To send a link exists between threads marshaling. We will use the universal marshaller, because we ActiveX DLL has a type library. The principle of work, I will not describe in detail, it has a lot of articles online. The general sense is that instead of a direct call to the object, the RPC request to another computer / process / thread. For processing queries need to use the message loop, and once it happened, then the communication between threads is done through the posts.
To test, I wrote a simple ActiveX DLL that lets you download a file from a network that has several methods and generates events.
Code:

' Класс MultithreadDownloader - класс загрузчика
' © Кривоус Анатолий Анатольевич (The trick), 2014
 
Option Explicit
 
Public Enum ErrorCodes
    OK
    NOT_INITIALIZE
    ERROR_CREATING_DST_FILE
End Enum
 
Private Declare Function InternetCloseHandle Lib "wininet" (ByRef hInternet As Long) As Boolean
Private Declare Function InternetOpen Lib "wininet" Alias "InternetOpenW" (ByVal lpszAgent As Long, ByVal dwAccessType As Long, ByVal lpszProxy As Long, ByVal lpszProxyBypass As Long, ByVal dwFlags As Long) As Long
Private Declare Function InternetOpenUrl Lib "wininet" Alias "InternetOpenUrlW" (ByVal hInternet As Long, ByVal lpszUrl As Long, ByVal lpszHeaders As Long, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByRef dwContext As Long) As Long
Private Declare Function InternetReadFile Lib "wininet" (ByVal hFile As Long, lpBuffer As Any, ByVal dwNumberOfBytesToRead As Long, ByRef lpdwNumberOfBytesRead As Long) As Integer
Private Declare Function HttpQueryInfo Lib "wininet" Alias "HttpQueryInfoW" (ByVal hRequest As Long, ByVal dwInfoLevel As Long, lpBuffer As Any, ByRef lpdwBufferLength As Long, ByRef lpdwIndex As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileW" (ByVal lpFileName As Long, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
 
Private Const INTERNET_OPEN_TYPE_PRECONFIG  As Long = 0
Private Const INTERNET_FLAG_RELOAD          As Long = &H80000000
Private Const HTTP_QUERY_CONTENT_LENGTH    As Long = 5
Private Const HTTP_QUERY_FLAG_NUMBER        As Long = &H20000000
Private Const CREATE_ALWAYS                As Long = 2
Private Const FILE_ATTRIBUTE_NORMAL        As Long = &H80
Private Const INVALID_HANDLE_VALUE          As Long = -1
Private Const GENERIC_WRITE                As Long = &H40000000
 
Public Event Complete()
Public Event Error(ByVal Code As Long)
Public Event Progress(ByVal Size As Currency, ByVal TotalSize As Currency, cancel As Boolean)
 
Private mBufferSize As Long
Private mError      As ErrorCodes
 
Dim hInternet  As Long
 
Public Property Get ErrorCode() As ErrorCodes
    ErrorCode = mError
End Property
 
Public Property Get BufferSize() As Long
    BufferSize = mBufferSize
End Property
Public Property Let BufferSize(ByVal Value As Long)
    If Value > &H1000000 Or Value < &H400 Then Err.Raise vbObjectError, "MultithreadDownloader", "Wrong buffer size": Exit Property
    mBufferSize = Value
End Property
 
Public Sub Download(URL As String, Filename As String)
    Dim hFile  As Long
    Dim hDst    As Long
    Dim fSize  As Currency
    Dim total  As Long
    Dim prgSize As Currency
    Dim cancel  As Boolean
    Dim buf()  As Byte
   
    If hInternet = 0 Then mError = NOT_INITIALIZE: RaiseEvent Error(mError): Exit Sub
    hFile = InternetOpenUrl(hInternet, StrPtr(URL), 0, 0, INTERNET_FLAG_RELOAD, 0)
   
    If hFile = 0 Then mError = Err.LastDllError: RaiseEvent Error(mError): Exit Sub
   
    If HttpQueryInfo(hFile, HTTP_QUERY_CONTENT_LENGTH Or HTTP_QUERY_FLAG_NUMBER, fSize, 8, 0) Then
        hDst = CreateFile(StrPtr(Filename), GENERIC_WRITE, 0, ByVal 0&, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
        If hDst = INVALID_HANDLE_VALUE Then mError = ERROR_CREATING_DST_FILE: RaiseEvent Error(mError): Exit Sub
        ReDim buf(mBufferSize - 1)
        Do
            If InternetReadFile(hFile, buf(0), mBufferSize, total) = 0 Then
                mError = Err.LastDllError
                RaiseEvent Error(mError)
                InternetCloseHandle hFile
                Exit Sub
            End If
            WriteFile hDst, buf(0), total, 0, ByVal 0&
            prgSize = prgSize + CCur(total) / 10000@
            RaiseEvent Progress(prgSize, fSize, cancel)
        Loop While (total = mBufferSize) And Not cancel
        CloseHandle hDst
        RaiseEvent Complete
    Else
        mError = Err.LastDllError
        RaiseEvent Error(mError)
    End If
    InternetCloseHandle hFile
    mError = OK
End Sub
 
Private Sub Class_Initialize()
    ' Инициализация WinInet
    hInternet = InternetOpen(StrPtr(App.ProductName), INTERNET_OPEN_TYPE_PRECONFIG, 0, 0, 0)
    mBufferSize = &H10000
End Sub
 
Private Sub Class_Terminate()
    ' Деинициализация
    If hInternet Then InternetCloseHandle hInternet
End Sub

The code basically simple, if you read the description of the API functions. When calling the method "Download", starts will download from time to time (depending on the size of the buffer) event is generated Progress. If an error occurs, an event "Error", and at the end of the "Complete". "BufferSize" - sets the size of the buffer, which is generated when filling event. Demo code and contains bugs.*
Class I named "MultithreadDownloader", and the library "MTDownloader", respectively ProgID of the object - "MTDownloader.MultithreadDownloader". After compiling obtain a description of the interfaces through OleView, PEExplorer etc. In my example, CLSID = {20FAEF52-0D1D-444B-BBAE-21240219905B}, IID = {DF3BDB52-3380-4B78-B691-4138300DD304}. I also put a check "RemoteServerFiles" to get the output type library for our DLL, and will connect it instead of DLL for guaranteed start of the application.

[VB6] - Multithreading in VB6 part 3 - DLL injection.

0
0

Hello everyone! This part is rather more about DLL injections than about threading as such, but because DLL can run programs with different numbers of threads I made this as a continuation of the theme of multi-threading in VB6. In the last article, I wrote about the possibility of creating a thread in the DLL, and the method of creating a native DLL for VB6. I also wrote that such a DLL will work in any application, but did not result in an example. In this section we will write a DLL that will be performed in another 32-bit process and execute our code there. As an example, make an application that will perform subclassing a window in another thread and send messages in our application that we can handle. Write once - DLL for example only and is not intended for use in applications as There are disadvantages to minimize code as I did not eliminate.
I decided to make use of 3 cases:
  • Limiting the minimum size overlapping windows.
  • Tracking button press/release the mouse in the window.
  • Log messages.

So, first you need to come up with a interaction mechanism between processes. I decided to go the following way:
  • For the exchange of data between applications will use FileMapping.
  • To send a message from the proces- "victim" to our application, we will use a new recorded message.
  • For notification of completion subclassing will transmit a message to the other side.

Now you need to consider how to implement the launch. Put the hook "WH_GETMESSAGE" on a thread that contains the window. Now our DLL is loaded into the address space of the process of the victim. In the callback function "GetMsgProc" the first call will initialize the data and set the desired window subclassing to exchange as mentioned above use the file-mapping. So the code:
Code:

clare Function GetMem4 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function ReleaseMutex Lib "kernel32" (ByVal hMutex As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Integer, lParam As Any) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropW" (ByVal hWnd As Long, ByVal lpString As Long, ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropW" (ByVal hWnd As Long, ByVal lpString As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropW" (ByVal hWnd As Long, ByVal lpString As Long) As Long
Private Declare Function GlobalAddAtom Lib "kernel32" Alias "GlobalAddAtomW" (ByVal lpString As Long) As Integer
Private Declare Function GlobalDeleteAtom Lib "kernel32" (ByVal nAtom As Integer) As Integer
Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageW" (ByVal lpString As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcW" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Const GWL_WNDPROC        As Long = (-4)
Private Const INFINITE          As Long = -1&
Private Const MUTEX_ALL_ACCESS  As Long = &H1F0001
Private Const FILE_MAP_READ      As Long = &H4
Private Const FILE_MAP_WRITE    As Long = &H2
Private Const WAIT_FAILED        As Long = -1&

Private WM_SENDMESSAGE  As Long    ' Наше сообщение для обмена с основной программой. Отсылая из текущего потока это сообщение
                                    ' в наше приложение (TestSubclassDLL), мы уведомляем приложение через SendMessage о том, что
                                    ' пришло новое сообщение, параметры которого записаны в файловое представление. Передавая из
                                    ' главного (TestSubclassDLL) приложения сюда это сообщение, мы уведомляем о том, что нужно
                                    ' снять сабклассинг и выполнить деинициализацию.
   
Dim hMutex      As Long    ' Описатель мьютекса для синхронизации чтения/записи общих данных
Dim hMap        As Long    ' Хендл файлового отображения
Dim lpShrdData  As Long    ' Адрес общих данных
Dim hWndServer  As Long    ' Хендл окна для приема и обработки сообщений
Dim hWndHook    As Long    ' Хендл сабклассируемого окна в этом процессе
Dim hHook      As Long    ' Хендл хука, для передачи в CallNextHookEx
Dim aPrevProc  As Integer  ' Атом имени свойства изначальной оконной процедуры
Dim init        As Boolean  ' Инициализирован ли сабклассинг
Dim disabled    As Boolean  ' Сабклассинг окончен.

' // Процедура хука
Public Function GetMsgProc(ByVal code As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim prevProc    As Long
    ' Если не инициализирован сабклассинг - инициализируем
    If Not (init Or disabled) Then
        ' Открываем проекцию
        hMap = OpenFileMapping(FILE_MAP_WRITE, False, StrPtr("TrickSubclassFileMap"))
        If hMap = 0 Then MsgBox "Невозможно открыть проекцию", vbCritical: Clear: Exit Function
        ' Проецируем
        lpShrdData = MapViewOfFile(hMap, FILE_MAP_WRITE, 0, 0, 0)
        CloseHandle hMap: hMap = 0
        If lpShrdData = 0 Then MsgBox "Невозможно отобразить представление", vbCritical: Clear: Exit Function
        ' Открываем синхронизирующий мьютекс
        hMutex = OpenMutex(MUTEX_ALL_ACCESS, False, StrPtr("TrickSubclassMutex"))
        If hMutex = 0 Then MsgBox "Невозможно отрыть мьютекс", vbCritical: Clear: Exit Function
        ' Регистрация сообщения
        WM_SENDMESSAGE = RegisterWindowMessage(StrPtr(WM_SENDMESSAGE))
        If WM_SENDMESSAGE = 0 Then MsgBox "Невозможно Зарегистрировать сообщение", vbCritical: Clear: Exit Function
        ' Добавляем/получаем атом для сохранения предыдущей оконной процедуры
        aPrevProc = GlobalAddAtom(StrPtr("prevProc"))
        If aPrevProc = 0 Then MsgBox "Невозможно добавить атом", vbCritical: Clear: Exit Function
        ' Захватываем мьютекс. Если например в главном приложении еще не произошел выход из SetWindowsHookEx, то
        ' еще неизвестен хендл хука, а т.к. у нас там уже захвачен этот мьютекс, то этот поток будет ждать пока
        ' мьютекс не освободится, что произойдет только после записи хендля хука в общую память и остальных данных
        If WaitForSingleObject(hMutex, INFINITE) = WAIT_FAILED Then MsgBox "Ошибка ожидания", vbCritical: Clear: Exit Function
        ' Получаем хендл окна, которое будет принимать сообщения
        GetMem4 ByVal lpShrdData, hWndServer
        ' Получаем хендл сабклассируемого окна
        GetMem4 ByVal lpShrdData + 4, hWndHook
        ' Получаем хендл хука
        GetMem4 ByVal lpShrdData + 8, hHook
        ' Освобождаем мьютекс
        ReleaseMutex hMutex
        ' Получаем адрес оконной процедуры и задаем новый
        prevProc = SetWindowLong(hWndHook, GWL_WNDPROC, AddressOf WndProc)
        If prevProc = 0 Then MsgBox "Невозможно заменить оконную процедуру", vbCritical: Clear: Exit Function
        ' Установка свойства окна
        SetProp hWndHook, CLng(aPrevProc) And &HFFFF&, prevProc
        ' Успех
        init = True
    End If
    ' Передаем на обработку другим процедурам
    GetMsgProc = CallNextHookEx(hHook, code, wParam, lParam)
End Function

' // Деинициализация
Public Sub Clear()
    If hMutex Then CloseHandle (hMutex): hMutex = 0
    If lpShrdData Then UnmapViewOfFile (lpShrdData): lpShrdData = 0
    If hWndHook Then RemoveProp hWndHook, CLng(aPrevProc) And &HFFFF&: hWndHook = 0
    If aPrevProc Then GlobalDeleteAtom (aPrevProc): aPrevProc = 0
    init = False
End Sub

' // Оконная процедура
Private Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim sendData    As MsgData
    Dim prevProc    As Long
    ' Проверяем не снятие ли сабклассинга
    If uMsg = WM_SENDMESSAGE Then
        ' Получаем предыдущий адрес процедуры
        prevProc = GetProp(hWnd, CLng(aPrevProc) And &HFFFF&)
        ' Устанавливаем его оконной процедуре
        SetWindowLong hWnd, GWL_WNDPROC, prevProc
        ' Очистка
        Clear
        ' Отключаем сабклассинг
        ' Возможна ситуация когда будет вызвана GetMsgProc, до того, как будет снят хук в главно приложении
        ' этот флаг предотвращает повторную инициализацию данных.
        disabled = True
        Exit Function
        ' Теперь из главного приложения будет вызвана UnhookWindowsHookEx и наша DLL будет выгружена из памяти.
    End If
    ' Формируем запрос
    sendData.hWnd = hWnd
    sendData.uMsg = uMsg
    sendData.wParam = wParam
    sendData.lParam = lParam
    sendData.defCall = True
    ' Захватываем мьютекс
    If WaitForSingleObject(hMutex, INFINITE) = WAIT_FAILED Then MsgBox "Ошибка ожидания", vbCritical: Clear: Exit Function
    CopyMemory ByVal lpShrdData + 12, sendData, Len(sendData)
    ' Освобождаем мьютекс
    ReleaseMutex hMutex
    ' Отправляем сообщение главному окну
    SendMessage hWndServer, WM_SENDMESSAGE, 0, ByVal 0
    ' Получаем результат обработки
    If WaitForSingleObject(hMutex, INFINITE) = WAIT_FAILED Then MsgBox "Ошибка ожидания", vbCritical: Clear: Exit Function
    CopyMemory sendData, ByVal lpShrdData + 12, Len(sendData)
    ' Освобождаем мьютекс
    ReleaseMutex hMutex
    ' Следует ли обрабатывать его дальше
    If sendData.defCall Then
        prevProc = GetProp(hWnd, CLng(aPrevProc) And &HFFFF&)
        WndProc = CallWindowProc(prevProc, sendData.hWnd, sendData.uMsg, sendData.wParam, sendData.lParam)
    Else
        WndProc = sendData.return
    End If
End Function

[VB6] - Class for copying a file in a separate thread with display progress.

0
0

Hello everyone! There are times when you want to copy a large file (s), with a standard function "FileCopy" freezes the entire program as long as the copy is complete. I have developed a class that uses the possibilities of the function "CopyFileEx" (using ANSI version), display of progress and the possibility of canceling up, as well as multi-threading to run all functions in a background thread. When running the copy process, you can not stop the environment stop button, only closed (it is necessary to call the destructor), otherwise there may be glitches. Also, it is advisable not to run simultaneously copying many files as for each copy creates a separate thread, and large number of them will brake. For a single stream using inline assembly with the following code:
Code:

; Thread procedure
Copy:
    xor eax,eax        ; eax <- 0
    push eax              ; local variable pbCancel
    mov ecx,esp        ; ecx <- *pbCancel
    push eax            ; dwCopyFlags
    push ecx            ; *pbCancel
    push eax            ; lpData
    push 0x0            ; lpProgressRoutine
    push 0x0            ; lpNewFileName
    push 0x0            ; lpExitingFileName
    call 0x0            ; callCopyFileEx
    mov dword [0],eax  ; Return value
    xor eax,eax        ; dwExitCode
    call 0x0            ; call ExitThread
; callback function CopyProgressRoutine
CopyProgressRoutine:
    fild qword [esp+12] ; LARGE_INTEGER to floating point - TotalBytesTransferred
    fild qword [esp+4]  ; LARGE_INTEGER to floating point - TotalFileSize
    fdivp              ; devide by TotalFileSize
    fstp dword [0]      ; Save to variable
    mov eax, dword [0]  ; Return value
    ret 0x34

Instead of zeros, fit the data later in proceedings: "LoadStaticValue" - are those that will not change; "LoadDynamicValue" - the names of the files. You can use the class and one for multiple copying, or the same number of simultaneous backup.
Class code:
Code:

' Класс для фонового копирования файла, с отображением прогресса копирования
' Автор: © Кривоус Анатолий Анатольевич (The trick) 2013
Option Explicit
 
Private Declare Function HeapCreate Lib "kernel32" (ByVal flOptions As Long, ByVal dwInitialSize As Long, ByVal dwMaximumSize As Long) As Long
Private Declare Function HeapDestroy Lib "kernel32" (ByVal hHeap As Long) As Long
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (pSrc As Any, pDst As Any) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) 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 GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, lpExitCode As Long) As Long
Private Declare Function SetThreadPriority Lib "kernel32" (ByVal hThread As Long, ByVal nPriority As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
 
Public Enum StateOperation
    COMPLETED                                                      ' Операция закончена успешно
    ACTIVE                                                          ' Операция выполняется
    FAILED                                                          ' Операция завершилась неудачей
End Enum
 
Private Const STILL_ACTIVE = &H103&
Private Const PROGRESS_CONTINUE = 0
Private Const PROGRESS_CANCEL = 1
Private Const COPY_FILE_FAIL_IF_EXISTS = &H1
Private Const HEAP_CREATE_ENABLE_EXECUTE = &H40000
Private Const HEAP_NO_SERIALIZE = &H1
Private Const INFINITE = &HFFFFFFFF
Private Const THREAD_BASE_PRIORITY_MIN = -2
Private Const THREAD_PRIORITY_LOWEST = THREAD_BASE_PRIORITY_MIN
 
Private Const AsmSize As Long = 64                                  ' Размер вставки в байтах
 
Private mSourceFileName As String                                  ' Путь, откуда копируем
Private mDestinationFileName As String                              ' Путь, куда копируем
Private mProgress As Single                                        ' Прогресс 0..1
 
Dim hHeap As Long                                                  ' Дескриптор кучи
Dim lpFunc As Long                                                  ' Адрес функции в ассемблерной вставке
Dim init As Boolean                                                ' Инициализирован ли код потока
Dim Src() As Byte                                                  ' ASCII строка mSourceFileName
Dim Dst() As Byte                                                  ' ASCII строка mDestinationFileName
Dim ApiRet As Long                                                  ' Возвращаемое значение из API
Dim ProgressRet As Long                                            ' Возвращаемое значение из CopyProgressRoutine
Dim hThread As Long                                                ' Хендл потока
 
Public Property Get SourceFileName() As String                      ' Возвращает путь откуда копировать
    SourceFileName = mSourceFileName
End Property
Public Property Let SourceFileName(FileName As String)              '
    mSourceFileName = FileName
End Property
Public Property Get DestinationFileName() As String                ' Возвращает путь куда копировать
    DestinationFileName = mDestinationFileName
End Property
Public Property Let DestinationFileName(FileName As String)        '
    mDestinationFileName = FileName
End Property
Public Property Get Progress() As Single                            ' Возвращает значение от 0 до 1 прогресса копирования
    Progress = mProgress
End Property
Public Property Get State() As StateOperation                      ' Возвращает состояние выполнения операции
    If Process Then State = ACTIVE: Exit Property
    State = IIf(ApiRet, COMPLETED, FAILED)
End Property
Public Sub Copy()                                                  ' Запустить копирование
    Dim IDThrd As Long
   
    If Not init Or Process Then Exit Sub                            ' Если не инициализированы или уже идет процесс то выходим
    ProgressRet = PROGRESS_CONTINUE                                ' Установка продолжения процесса
    LoadDynamicValue
    ApiRet = -1                                                    ' Проверка возвращаемого значения CopyFileEx
    hThread = CreateThread(ByVal 0, 0, lpFunc, ByVal 0, 0, IDThrd)  ' Запуск нового потока
    If hThread = 0 Then ApiRet = 0: Exit Sub                        ' Если не удалось создать поток, тогда устанавливаем ошибку
    SetThreadPriority hThread, THREAD_PRIORITY_LOWEST              ' Устанавливаем низкий приоритет потоку копирования
End Sub
Public Function Cancel(Optional Wait As Boolean = False) As Boolean ' Остановить текущий процесс, ждать завершения?
    If Process Then                                                ' Имеет смысл только если идет процесс
        If Wait Then
            Call StopAll: Cancel = True                            ' Если ждем
        Else
            ProgressRet = PROGRESS_CANCEL                          ' Устанавливаем возвращаемое значение в CPR
            Cancel = True
        End If
    End If
End Function
Private Property Get Process() As Boolean                          ' Возвращает True если операция выполняется
    Dim Ret As Long
    If hThread = 0 Then Exit Property                              ' Если нет активного потока, тогда False
    GetExitCodeThread hThread, Ret                                  ' Запрашиваем, завершился ли поток
    If Ret = STILL_ACTIVE Then Process = True                      ' Если он активен, то возвращаем True
End Property
Private Sub StopAll()                                              ' Остановить все процессы
    ProgressRet = PROGRESS_CANCEL                                  ' Отменяем процессы
    If hThread Then
        WaitForSingleObject hThread, INFINITE                      ' Ждем завершения потока
    End If
    hThread = 0
End Sub
Private Sub CreateAsm(Asm() As Long)                                ' Создаем вставку
    ReDim Asm(-Int(-AsmSize / 4) - 1)                              ' Вычисляем нужный размер массива
    Asm(0) = &H8950C031: Asm(1) = &H505150E1: Asm(2) = &H68&
    Asm(3) = &H6800&: Asm(4) = &H680000: Asm(5) = &HE8000000
    Asm(6) = &H0&: Asm(7) = &HA3&: Asm(8) = &HE8C03100
    Asm(9) = &H0&: Asm(10) = &HC246CDF: Asm(11) = &H4246CDF
    Asm(12) = &H1DD9F9DE: Asm(13) = &H0&: Asm(14) = &HA1&
    Asm(15) = &H34C200
End Sub
Private Sub LoadDynamicValue()                                      ' Установка динамических значений в вставке
    Src = StrConv(mSourceFileName & vbNullChar, vbFromUnicode)      ' Переводим путь из Юникода в ANSI
    Dst = StrConv(mDestinationFileName & vbNullChar, vbFromUnicode) ' ...
   
    GetMem4 VarPtr(Src(0)), ByVal lpFunc + &H13&                    ' Установка указателя на Исходное размещение
    GetMem4 VarPtr(Dst(0)), ByVal lpFunc + &HE&                    ' Установка указателя на "Результирующее" размещение
End Sub
Private Sub LoadStaticValue(lpFunc As Long)                        ' Установка статичных значений в вставке
    Dim hKernel32 As Long                                          ' Хендл модуля Kernel32
    Dim lpCopyFileEx As Long                                        ' Адрес функции CopyFileEx
    Dim lpExitThread As Long                                        ' Адрес функции ExitThread
 
    hKernel32 = LoadLibrary("Kernel32.dll")                        ' Получаем хендл Kernel32.dll
    lpCopyFileEx = GetProcAddress(hKernel32, "CopyFileExA")        ' Получаем адреса функций ...
    lpExitThread = GetProcAddress(hKernel32, "ExitThread")          '
   
    GetMem4 lpFunc + &H28&, ByVal lpFunc + &H9&                    ' Установка указателя на CopyProgressRoutine
    GetMem4 lpCopyFileEx - (lpFunc + &H1C&), ByVal lpFunc + &H18&  ' Установка перехода на CopyFileExA
    GetMem4 lpExitThread - (lpFunc + &H28&), ByVal lpFunc + &H24&  ' Установка перехода на ExitThread
   
    GetMem4 VarPtr(ApiRet), ByVal lpFunc + &H1D&                    ' Установка указателя на возвращаемое значение CopyFileEx
    GetMem4 VarPtr(mProgress), ByVal lpFunc + &H34&                ' Установка указателя на mProgress
    GetMem4 VarPtr(ProgressRet), ByVal lpFunc + &H39&              ' Установка указателя на возвращаемое значение CPR
End Sub
Private Sub Class_Initialize()
    Dim Asm() As Long                                              ' Буфер с ассемблерной вставкой
   
    CreateAsm Asm                                                  ' Создаем вставку
    hHeap = HeapCreate(HEAP_CREATE_ENABLE_EXECUTE Or _
            HEAP_NO_SERIALIZE, AsmSize, AsmSize)                    ' Создаем кучу, с разрешением для выполнения,
                                                                    ' размером с ассемблерную вставку
    If hHeap = 0 Then MsgBox "Error creating heap", vbCritical: _
            Exit Sub                                                ' При ошибке выходим
    lpFunc = HeapAlloc(hHeap, HEAP_NO_SERIALIZE, AsmSize)          ' Выделяем память в куче
    If lpFunc = 0 Then MsgBox "HeapAlloc return NULL", _
            vbCritical: Call Class_Terminate: Exit Sub              ' Не удалось выделить память
    CopyMemory ByVal lpFunc, Asm(0), AsmSize                        ' Копируем вставку в выделенную память
    LoadStaticValue lpFunc
    ApiRet = -1                                                    ' Чтобы отрабатывало свойство State
    init = True                                                    ' Инициализация успешно
End Sub
Private Sub Class_Terminate()
    If Process Then
        StopAll                                                    ' Останавливаем
    End If
    If lpFunc Then
        HeapFree hHeap, HEAP_NO_SERIALIZE, ByVal lpFunc            ' Освобождаем выделенную память
    End If
    If hHeap Then
        HeapDestroy hHeap                                          ' Удаляем кучу
    End If
End Sub

[VB6] - Multi-line standard tooltip.

0
0

Standard tooltip (property "ToolTipText" of controls) does not support multi-line text and displays all the text on one line. Suggest module that supports "multiline" standard tooltip based on subclassing windows tooltip. Can, in principle, and the color and design to change the tooltip if you wish, I left the standard; You can also add width adjustment (so as not to produce a lot of code I left centered), commented on almost every line. Button to stop the project after the launch of "hook" can not be otherwise crash IDE (I have Win7 (64), not falling apart; always took off on XP), it is necessary to close the window and call "Unhook".

MultilineTooltip.zip
Attached Files

[VB6] - Injection to another process.

0
0

Everyone knows the utility SPYXX. With it you can do a lot of interesting things. Among its features - View messages sent by the window, and the results of their treatment. I decided to do something like that just to VB6 (not as the creation of programs such as SPYXX, as well as a demonstration of the possibility of an injection of code from VB6, so that the functionality of a program is very small). As you know SPYXX does this by using a global hook, but I was interested in the idea of injection without DLL (DLL can be much easier to do, Richter describes how to inject several functions in a foreign process using DLL, and I put an example) and I decided to do a little differently. In my example code along with the window procedure directly copied into the address space of the desired process and it starts (only works with 32-bit applications). There I place the code that establishes a new procedure for processing messages for the window and sleeping thread. In the new procedure, I just superfluous to pass a parameter that someone else got the window, my window (frmSpy), hereinafter called the original window procedure. I have to say - the transfer is not the most efficient way, it was possible to make a much more effective working directly with "FileMapping", or asynchronously transmit 2 posts in a row. But I did not complicate the code over, because my ultimate goal is not effective. Cancel injection is performed awakening threads and completion of its natural way, then from its program I release resources. Work I checked in the debugger everything works as intended.
When running in another process, the runtime is not used, although it is possible to download and use (about context initialization thread separately) its functions, arrays, strings, etc. Also, there is a problem working with variables, as global variables "does not exist", and, accordingly, any reference to such variables could be fatal to the whole process. To call the API I'm using splicing "pseudofunctions API", replace the call to an unconditional jump to the desired function. Working with variables is carried out in a dedicated area for this. To keep it, I use "SetProp", because from "WindowProc" I can identify something only through "hWnd". If you need to add any global variables, it is possible in this field to allocate space for the string, etc. (for example to call "LoadLibrary" with the required parameter). If in VB was to work directly with pointers (without VarPtr, GetMem functions, etc.), it was much easier. You can do once the assembly adapter and it is possible to learn the values of variables passed to the stream without "SetProp" and "CopyMemory", but it's the details, who wants to - he did.
Everything works only in a compiled (native) form.

[VB6] - Calling functions by pointer.

0
0
Exploring the function VBA6 figured out a way to call functions the pointer.
It's simple. Declare a function prototype (void function), where the first argument will be further transferred to the function address. Next, do a patch, so he tossed to us at the address specified in the first parameter. Thus it is possible to call functions in the standard modules, class modules, forms, API-functions (eg obtained through LoadLibrary and GetProcAddress).* One note, run the project through Ctrl + F5. And working in the IDE and compiled form.
For "patching" the prototype I made a separate module:
Code:

Option Explicit

Private Declare Function GetMem4 Lib "msvbvm60" (src As Any, dst As Any) As Long
Private Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
Private Declare Sub EbGetExecutingProj Lib "vba6" (hProject As Long)
Private Declare Function TipGetFunctionId Lib "vba6" (ByVal hProj As Long, ByVal bstrName As Long, ByRef bstrId As Long) As Long
Private Declare Function TipGetLpfnOfFunctionId Lib "vba6" (ByVal hProject As Long, ByVal bstrId As Long, ByRef lpAddress As Long) As Long
Private Declare Sub SysFreeString Lib "oleaut32" (ByVal lpbstr As Long)

Private Const PAGE_EXECUTE_READWRITE = &H40

' Вспомогательные функции
Public Sub PatchFunc(FuncName As String, ByVal Addr As Long)
    Dim lpAddr As Long, hProj As Long, sId As Long, InIDE As Boolean

    Debug.Assert MakeTrue(InIDE)

    ' Получаем адрес функции
    If InIDE Then
        EbGetExecutingProj hProj
        TipGetFunctionId hProj, StrPtr(FuncName), sId
        TipGetLpfnOfFunctionId hProj, sId, lpAddr
        SysFreeString sId
    Else
        lpAddr = GetAddr(Addr)
        VirtualProtect lpAddr, 8, PAGE_EXECUTE_READWRITE, 0
    End If

    ' Записываем вставку
    ' Запускать только по Ctrl+F5!!
    ' pop eax
    ' pop ecx
    ' push eax
    ' jmp ecx

    GetMem4 &HFF505958, ByVal lpAddr
    GetMem4 &HE1, ByVal lpAddr + 4
End Sub

Private Function GetAddr(ByVal Addr As Long) As Long
    GetAddr = Addr
End Function
Public Function MakeTrue(ByRef bvar As Boolean) As Boolean
    bvar = True: MakeTrue = True
End Function

Example call normal functions in a standard module:
Code:

' Пример вызова обычных функции по указателю
Public Sub Main()

    ' Пропатчиваем функции, перед первым вызовом
    PatchFunc "Proto1", AddressOf Proto1
    PatchFunc "Proto2", AddressOf Proto2

    MsgBox Proto1(AddressOf Func1, 1, "Вызов")
    MsgBox Proto1(AddressOf Func2, 2, "По указателю")
    MsgBox Proto1(AddressOf Func3, 3, ";)")

    Call Proto2(AddressOf Sub1)
    Call Proto2(AddressOf Sub2)
End Sub

' Прототип функций
Private Function Proto1(ByVal Addr As Long, ByVal x As Long, y As String) As String
End Function
Private Sub Proto2(ByVal Addr As Long)
End Sub
' Функции
Private Function Func1(ByVal x As Long, y As String) As String
    Func1 = "Func1_" & y
End Function
Private Function Func2(ByVal x As Long, y As String) As String
    Func2 = "Func2_" & y
End Function
Private Function Func3(ByVal x As Long, y As String) As String
    Func3 = "Func3_" & y
End Function
Private Sub Sub1()
    MsgBox "Sub1"
End Sub
Private Sub Sub2()
    MsgBox "Sub2"
End Sub

Example API calls at getting through GetProcAddress:
Code:

Private Declare Function GetMem4 Lib "msvbvm60" (src As Any, dst As Any) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long


' Пример вызова WinApi функций по указателю
Public Sub Main()
    Dim hUser As Long, hGDI As Long
    Dim DC As Long

    hUser = LoadLibrary("user32")
    hGDI = LoadLibrary("gdi32")

    PatchFunc "GetDC", AddressOf GetDC
    PatchFunc "ReleaseDC", AddressOf ReleaseDC
    PatchFunc "Ellipse", AddressOf Ellipse

    DC = GetDC(GetProcAddress(hUser, "GetDC"), 0)
    Ellipse GetProcAddress(hGDI, "Ellipse"), DC, 0, 0, 500, 500
    ReleaseDC GetProcAddress(hUser, "ReleaseDC"), 0, DC
End Sub

' Прототип функций
Private Function GetDC(ByVal Addr As Long, ByVal hWnd As Long) As Long
End Function
Private Function ReleaseDC(ByVal Addr As Long, ByVal hWnd As Long, ByVal hdc As Long) As Long
End Function
Private Function Ellipse(ByVal Addr As Long, ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
End Function

Example call class methods on the pointer:
.bas module:
Code:

Private Declare Function GetMem4 Lib "msvbvm60" (src As Any, dst As Any) As Long

' Пример вызова методов объекта по указателю
Public Sub Main()
    Dim IUnk    As Long
    Dim lpProp  As Long
    Dim lpView  As Long
    Dim Obj1    As clsTest
    Dim Obj2    As clsTest
    Dim ret    As Long

    Set Obj1 = New clsTest
    Set Obj2 = New clsTest
   
    GetMem4 ByVal ObjPtr(Obj1), IUnk
    GetMem4 ByVal IUnk + &H1C, lpProp
    GetMem4 ByVal IUnk + &H20, lpView
   
    PatchFunc "clsTest_PropLet", AddressOf clsTest_PropLet
    PatchFunc "clsTest_View", AddressOf clsTest_View
   
    clsTest_PropLet lpProp, Obj1, 1234
    clsTest_PropLet lpProp, Obj2, 9876
   
    clsTest_View lpView, Obj1, ret
    Debug.Print ret
    clsTest_View lpView, Obj2, ret
    Debug.Print ret
End Sub

' Прототип функций
Private Function clsTest_PropLet(ByVal Addr As Long, ByVal Obj As clsTest, ByVal Value As Long) As Long
End Function
Private Function clsTest_View(ByVal Addr As Long, ByVal Obj As clsTest, ret As Long) As Long
End Function

Class module:
Code:

Option Explicit

Dim mValue As Long

Public Property Let Prop(ByVal Value As Long)
    mValue = Value
End Property
Public Function View() As Long
    View = MsgBox(mValue, vbYesNoCancel)
End Function

Good luck!

CallPointer.zip
Attached Files

[VB6] - View GIF animation.

0
0
Hello everyone! You can view the animation in any window that has a property "hWnd". Are also respected the speed and number of repetitions (as in the original GIF'e) are also important parameters are displayed on the screen. In principle, if a little more refined, you can shove in class and ready to work with animations at the object level. You can pause, play, and stop "in the beginning." Drawing made with "double-buffered", so that will not flicker. For use in the project, just plug and call the same methods, no additional control is not necessary, of course apart from the container.
Standart module:
Code:

Declaration  - see source.
...
' Локальные переменные уровня модуля
Dim mHwnd As Long, Init As Boolean, token As Long, img As Long, frames As Long, gr As Long, prevwndproc As Long
Dim tInit As Boolean, frame() As Long, loops As Long, index As Long, cycle As Long, isplay As Boolean
 
' Хендл окна в котором будем рисовать анимацию
Public Property Get hwnd() As Long
    hwnd = mHwnd
End Property
Public Property Let hwnd(ByVal value As Long)
    StopAnim                                                                                    ' Останавливаем анимацию
    If hwnd Then UnHook                                                                        ' Если до этого сабклассили, то отключаем сабклассинг
    mHwnd = value
    Hook                                                                                        ' Сабклассим новое окно
End Property
' Ширина кадра анимации
Public Property Get Width() As Long
    GdipGetImageWidth img, Width
End Property
' Высота кадра анимации
Public Property Get Height() As Long
    GdipGetImageHeight img, Height
End Property
' Текущий кадр
Public Property Get CurrentFrame() As Long
    CurrentFrame = index
End Property
' Количество кадров
Public Property Get FramesCount() As Long
    FramesCount = frames
End Property
' Сколько циклов анимации
Public Property Get LoopCount() As Long
    LoopCount = loops
End Property
' Проигрывается ли анимация
Public Property Get IsPlaying() As Boolean
    IsPlaying = isplay
End Property
' Загрузка файла анимации
Public Function LoadAnimation(ByVal FileName As String) As Boolean
    Dim GpInput As GdiplusStartupInput                                                          ' Для инициализации GDI+
    Dim pc As Long, sz As Long, pi As PropertyItem
    Dim buf() As Byte                                                                          ' Буффер для свойств
   
    If Not Init Then                                                                            ' Если не инициализирован GDI+
        GpInput.GdiplusVersion = 1
        If GdiplusStartup(token, GpInput) Then Exit Function Else Init = True                  ' Инициализируем, при неудаче выходим
    End If
    Clear                                                                                      ' Очистка, если до этого что-то загружали
    If GdipLoadImageFromFile(StrConv(FileName, vbUnicode), img) Then Exit Function              ' Загружаем картинку
    If GdipImageGetFrameCount(img, DEFINE_GUID(FrameDimensionTime), frames) Then                ' Проверяем кол-во кадров
        GdipDisposeImage img                                                                    ' При неудаче удаляем картинку и выходим (возможно что не GIF)
        Exit Function
    End If
    ' Узнаем время каждого кадра
    GdipGetPropertyItemSize img, PropertyTagFrameDelay, sz                                      ' Получаем размер свойства в байтах
    If sz > 0 And frames > 1 Then                                                              ' Имеет смысл только если кадров>1
        ReDim buf(sz - 1)                                                                      ' Выделяем буфер
        GdipGetPropertyItem img, PropertyTagFrameDelay, sz, buf(0)                              ' Копируем свойство в буфер
        CopyMemory pi, buf(0), Len(pi)                                                          ' Копируем в описатель
        ReDim frame(frames - 1)                                                                ' Выделяем кадровый буфер (длительности)
        CopyMemory frame(0), buf(Len(pi)), pi.Length                                            ' Копируем значения длительностей
    End If
    ' Узнаем зациклена ли анимация
    GdipGetPropertyItemSize img, PropertyTagLoopCount, sz
    If sz > 0 And frames > 1 Then
        ReDim buf(sz - 1)
        GdipGetPropertyItem img, PropertyTagLoopCount, sz, buf(0)
        CopyMemory pi, buf(0), Len(pi)
        GetMem2 buf(Len(pi)), loops
    End If
    index = 0: cycle = 0                                                                        ' Очистка счетчиков
    LoadAnimation = True                                                                        ' Успешно
End Function
' Проигрыш анимации
Public Function PlayAnim() As Boolean
    If Init And hwnd <> 0 And img <> 0 And Not isplay Then
        If frames > 1 Then                                                                      ' Смысл запускать таймер если кадров > 1
            If SetTimer(mHwnd, 1, frame(index) * 10, AddressOf TimerProc) = 0 Then _
                                                    Exit Function                              ' Не удалось запустить таймер
        End If
        tInit = True                                                                            ' Таймер инициализирован
        isplay = True                                                                          ' Включен проигрыш
        PlayAnim = True                                                                        ' Возвращаем успешное значение
        RedrawWindow mHwnd, ByVal 0, 0, RDW_INVALIDATE                                          ' Перерисовываем
    End If
End Function
' Пауза
Public Function Pause() As Boolean
    If isplay Then                                                                              ' Если играем
        isplay = False                                                                          ' то останавливаем
        Pause = True                                                                            ' Возвращаем успешное значение
        StopTimer                                                                              ' Останавливаем таймер
    End If
End Function
' Остановка анимации
Public Sub StopAnim()
    isplay = False                                                                              ' Останавливаем проигрывание
    index = 0                                                                                  ' Обнуляем текущий кадр
    cycle = 0                                                                                  ' Обнуляем счетчик циклов
    StopTimer                                                                                  ' Останавливаем таймер
    RedrawWindow mHwnd, ByVal 0, 0, RDW_INVALIDATE                                              ' Перерисовываем
End Sub
' Завершение работы
Public Sub ShutDown()
    Clear                                                                                      ' Очистка ресурсов
    If mHwnd Then UnHook                                                                        ' Если сабклассили то выключаем сабклассинг
    GdiplusShutdown token                                                                      ' Выключаем GDI+
End Sub
' Очистка ресурсов
Private Sub Clear()
    frames = 0                                                                                  ' Обнуляем количество кадров
    Erase frame()                                                                              ' Удаляем массив длительностей кадров
    If img Then GdipDisposeImage img                                                            ' Удаляем картинку
    StopAnim                                                                                    ' Останавливаем анимацию
End Sub
' Остановка таймера
Private Sub StopTimer()
    If tInit Then                                                                              ' Если таймер инициализирован
        KillTimer mHwnd, 1                                                                      ' Удаляем его
        tInit = False                                                                          ' Таймер не инициализирован
    End If
End Sub
' Из строки в GUID
Private Function DEFINE_GUID(ByVal sGuid As String) As CLSID
    Call CLSIDFromString(StrPtr(sGuid), DEFINE_GUID)                                            ' GUID из строкового параметра
End Function
' Сабклассинг
Private Sub Hook()
    prevwndproc = SetWindowLong(mHwnd, GWL_WNDPROC, AddressOf WndProc)                          ' Назначаем свою оконную процедуру
End Sub
Private Sub UnHook()
    SetWindowLong mHwnd, GWL_WNDPROC, prevwndproc                                              ' Возвращаем оконную процедуру
End Sub
' Оконная процедура
Private Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim ps As PAINTSTRUCT, tdc As Long, tbmp As Long, obmp As Long, rc As RECT
    Select Case Msg
    Case WM_PAINT                                                                              ' Отрисовка
        If index = -1 Or Not Init Then
            WndProc = CallWindowProc(prevwndproc, hwnd, Msg, wParam, lParam)                    ' Если нет активной анимации рисуем как было
        Else
            ' Для предотвращения мерцания, например анимаций с черным фоном, я решилл использовать двойную буфферизацию
            GetClientRect hwnd, rc                                                              ' Узнаем размер ко контрола
            BeginPaint hwnd, ps
            tdc = CreateCompatibleDC(ps.hdc)                                                    ' Буфферный DC
            tbmp = CreateCompatibleBitmap(ps.hdc, rc.iRight, rc.iBottom)                        ' Буфферная картинка
            obmp = SelectObject(tdc, tbmp)
            GdipCreateFromHDC tdc, gr                                                          ' Создаем Graphics
            GdipGraphicsClear gr, &HFFFFFFFF                                                    ' Заливаем белым цветом
            GdipImageSelectActiveFrame img, DEFINE_GUID(FrameDimensionTime), index              ' Выбираем текущий кадр
            GdipDrawImage gr, img, 0, 0                                                        ' Рисуем его
            GdipDeleteGraphics gr                                                              ' Удаляем Graphics
            BitBlt ps.hdc, 0, 0, rc.iRight - rc.iLeft, _
                  rc.iBottom - rc.iTop, tdc, 0, 0, vbSrcCopy                                  ' Отрисовка из буфера
            SelectObject tdc, obmp                                                              ' Восстанавливаем и удаляем ....
            DeleteObject tbmp
            DeleteDC tdc
            EndPaint hwnd, ps
        End If
    Case Else
        WndProc = CallWindowProc(prevwndproc, hwnd, Msg, wParam, lParam)                        ' Остальное нас не интересует
    End Select
End Function
' Процедура таймера
Private Sub TimerProc(ByVal hwnd As Long, ByVal Msg As Long, idEvent As Long, ByVal dwTime As Long)
    index = index + 1                                                                          ' Кадр увеличился
    If index >= frames Then                                                                    ' Если переаолнение кадров
        index = 0                                                                              ' В начало
        cycle = cycle + 1                                                                      ' Увеличиваем циклы
        If cycle > loops And CBool(loops) Then StopAnim: Exit Sub                              ' Если переполнение циклов то выключаем анимацию
    End If
    RedrawWindow mHwnd, ByVal 0, 0, RDW_INVALIDATE                                              ' Перерисовываем
    If SetTimer(mHwnd, 1, frame(index) * 10, AddressOf TimerProc) = 0 Then                      ' Устанавливаем новую задержку
        StopAnim                                                                                ' Не удалось запустить таймер
    End If
End Sub

P.S. When debugging, it is desirable to stop the project form is closed, rather than using the Stop button, otherwise it may "crash" IDE.
Good luck!

GifViewer.zip
Attached Files

[VB6] - Translation of the string to a number and vice versa.

0
0
Hello everyone! Basic functions for translation and validation of numbers to strings (and back) is very uncomfortable in terms of the fact that there is a lot to write, and they have their "eat." We can write the numbers in the hexadecimal system or brackets in exponential notation, etc. On the one hand it is good, but on the other can be a challenge. I wrote two functions that convert decimal integers of unlimited dimension from one representation to another. Can be useful for example to display the (Setup) LARGE_INTEGER or any other large (very large scale) numbers. Can somehow make a module for arithmetic operations with such numbers.
Code:

Option Explicit
 
Private Declare Function GetMem2 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
 
Private Sub Form_Load()
    Dim Value() As Byte, Res As String
 
    StrToUI "1234567891011121314151617181920", Value
   
    Res = UIToStr(Value)
   
End Sub

' Convert unsigned integer from byte array to string (decimal system)
Private Function UIToStr(bValue() As Byte) As String
    Dim i As Long, f As Boolean, loc() As Byte
    loc = bValue
    Do
        i = Div10UI(loc)
        UIToStr = CStr(i) & UIToStr
        f = False
        For i = UBound(loc) To 0 Step -1
            If loc(i) Then f = True: Exit For
        Next
    Loop While f
End Function

' Convert unsigned integer (decimal system) from string to byte array.
Private Sub StrToUI(sValue As String, Out() As Byte)
    Dim i As Long, lpStr As Long, v As Integer, b(0) As Byte
    ReDim Out(0)
    If Len(sValue) Then
        lpStr = StrPtr(sValue)
        For i = 0 To Len(sValue) - 1
            GetMem2 ByVal lpStr, v
            v = v - &H30
            If v < 0 Or v > 9 Then Err.Raise 13: Exit Sub
            b(0) = v
            If i Then Mul10UI Out
            AddUI Out, b()
            lpStr = lpStr + 2
        Next
    Else: Err.Raise 5
    End If
End Sub

Private Sub AddUI(Op1() As Byte, Op2() As Byte)
    Dim i As Long, p As Long, o As Long, q As Long
    If UBound(Op1) < UBound(Op2) Then ReDim Preserve Op1(UBound(Op2))
    Do
        If i <= UBound(Op2) Then o = Op2(i) Else o = 0
        q = CLng(Op1(i)) + o + p
        p = (q And &H100&) \ &H100
        Op1(i) = q And &HFF
        i = i + 1
    Loop While CBool(o Or p) And i <= UBound(Op1)
    If p Then ReDim Preserve Op1(i): Op1(i) = p
End Sub

Private Function Div10UI(Value() As Byte) As Long
    Dim i1 As Long, i2 As Long, acc() As Byte, loc() As Byte, q As Long, p As Long
    For i1 = 0 To (UBound(Value) + 1) * 8
        Div10UI = (Div10UI * 2) Or p
        If Div10UI < 10 Then p = 0 Else p = 1: Div10UI = Div10UI - 10
        For i2 = 0 To UBound(Value)
            q = (CLng(Value(i2)) * 2) Or p
            p = (q And &H100) \ &H100
            Value(i2) = q And &HFF&
        Next
    Next
End Function

Private Sub Mul10UI(Value() As Byte)
    Dim i As Long, p As Long, q As Long
    For i = 0 To UBound(Value)
        q = (CLng(Value(i)) * 4 + Value(i)) * 2 + p
        p = (q And &HFF00&) \ &H100
        Value(i) = q And &HFF
    Next
    If p Then ReDim Preserve Value(i): Value(i) = p
End Sub

Good luck!

[VB6] - Multithreading in VB6 part 4 - multithreading in Standart EXE.

0
0

Hello everyone. Now I have a little time, so I have not often been programming BASIC and less likely to appear on the forum. Today again I will be talking about multi-threading, this time in the Standart EXE. I must say that all of what I write is my personal study, and may in some way does not correspond to reality; also due to my lack of time I will complement this post with further progress in the study of this issue. So here we go.
As I said before, to multithreading worked need to initialize the runtime. Without initialization we can work very limited in the sense that the COM will not work, ie roughly all the power of BASIC is not available. You can work with the API, declared in tlb, some functions, also removing the check __vbaSetSystemError, you can use Declared-function. All previous publications showing work in separate DLL, and we could easily initialize runtime using VBDllGetClassObject function for this. Today we will try to initialize the runtime in the usual EXE, ie without using external dependencies. It's no secret that any application written in VB6 has a project header, which contains a lot of information about the project that the runtime uses to work:
Code:

Type VbHeader
    szVbMagic              As String * 4
    wRuntimeBuild          As Integer
    szLangDll              As String * 14
    szSecLangDll            As String * 14
    wRuntimeRevision        As Integer
    dwLCID                  As Long
    dwSecLCID              As Long
    lpSubMain              As Long
    lpProjectInfo          As Long
    fMdlIntCtls            As Long
    fMdlIntCtls2            As Long
    dwThreadFlags          As Long
    dwThreadCount          As Long
    wFormCount              As Integer
    wExternalCount          As Integer
    dwThunkCount            As Long
    lpGuiTable              As Long
    lpExternalCompTable    As Long
    lpComRegisterData      As Long
    bszProjectDescription  As Long
    bszProjectExeName      As Long
    bszProjectHelpFile      As Long
    bszProjectName          As Long
End Type

In this structure, a lot of fields to describe all I will not, I will note only that this structure refers to a variety of other structures. Some of them will be needed in the future, such as a field lpSubMain, which contains the address of the procedure Main, if it is defined, otherwise there is 0. The vast majority of EXE files begin with the following code:
Code:

PUSH xxxxxxxx
CALL MSVBVM60.ThunRTMain

Just xxxxxxxx points to structure VBHeader. This feature will allow to find the structure inside the EXE for initializing runtime. In a previous article, I described how to get from the ActiveX DLL that structure - for this it was necessary to read the data in one of the exported functions (eg DllGetClassObject). To get from EXE - we also make use of the same method. First you need to find an entry point (entry point), ie address that starts the EXE. This address can be obtained from the structure IMAGE_OPTIONAL_HEADER - field AddressOfEntryPoint. This structure (IMAGE_OPTIONAL_HEADER) is located in the PE header, and the PE header is located at offset specified in the field e_lfanew from structure IMAGE_DOS_HEADER, well, IMAGE_DOS_HEADER structure located in the address specified in App.hInstance (or GetModuleHandle). Pointer to VbHeader is located at offset AddressOfEntryPoint + 1, because push-opcode in this case equal 0x68h. So, gathering all together, we get the function to get the Header:
Code:

' // Get VBHeader structure
Private Function GetVBHeader() As Long
    Dim ptr    As Long
    ' Get e_lfanew
    GetMem4 ByVal hModule + &H3C, ptr
    ' Get AddressOfEntryPoint
    GetMem4 ByVal ptr + &H28 + hModule, ptr
    ' Get VBHeader
    GetMem4 ByVal ptr + hModule + 1, GetVBHeader
   
End Function

Now, if you pass this structure VBDllGetClassObject function in a new thread, then, roughly speaking, this function will start our project for execution according to this structure. Of course in this sense is not enough - it is the same as re-start the application in the new thread. For example, if the function has been set Main, and then start again with the execution of it, and if the form has, then this form. Must somehow make the project was carried out on the other, do we need in the function. To do this, you can change the field "lpSubMain" in the structure vbHeader. I also did so at first, but it has given nothing. As it turned out, in runtime, there is one global object that stores a reference to projects and related objects, and if you pass the same header at VBDllGetClassObject, then the runtime checks are not loaded if such a project, and if loaded, simply launch a new copy without parse structure vbHeader, based on the previous analysis. So I decided to do so - you can copy the structure vbHeader to another location and use it. Immediately, I note that in this structure the last 4 fields - is offset with respect to the structure, so when copying the structure they need to be adjusted. If we now try to pass this structure to VBDllGetClassObject, then everything will be fine if installed as a startup Sub Main, if the form, it will be launched and the shape and after the Main. To exclude such behavior need to fix some data referenced by the title. I do not know exactly what kind of data, as did not understand this, but "dig deeper" inside the runtime I found their place position. Field "lpGuiTable" in the structure "vbHeader" refers to a list of structures tGuiTable, which describe froms in the project. Structures are sequentially the number of structures has a field "wFormCount" in the structure "vbHeader". In the network, I have not found the normal description of the structure tGuiTable, that's what is:
Code:

Type tGuiTable
    lStructSize          As Long
    uuidObjectGUI        As uuid
    Unknown1            As Long
    Unknown2            As Long
    Unknown3            As Long
    Unknown4            As Long
    lObjectID            As Long
    Unknown5            As Long
    fOLEMisc            As Long
    uuidObject          As uuid
    Unknown6            As Long
    Unknown7            As Long
    aFormPointer        As Long
    Unknown8            As Long
End Type

As it turned out there inside the runtime code that checks the field "Unknown5" in each structure:

I've added comments; They show that "Unknown5" contains flags and if you have installed the 5th bit, the recording is a reference to some object defined register EAX, in the field at offset 0x30 within the object specified register EDX. What kind of objects - I do not know, maybe later will deal with this, we have the important fact of the recording of a value in the field at offset 0x30. Now, if you start to explore more code you can stumble on such a fragment:

I will say that the object pointed to by ESI, the same object in the previous procedure under consideration (register EDX). It can be seen that the value of this field is tested for 0 and -1, and if there is any of the numbers that starts the procedure Main (unless specified); otherwise runs the first form. So, now that is guaranteed to run only Sub Main, we change the flag lpGuiTable.Unknown5, resetting the fifth bit. To install a new Sub Main and modification flag I created a separate procedure:
Code:

' // Modify VBHeader to replace Sub Main
Private Sub ModifyVBHeader(ByVal newAddress As Long)
    Dim ptr    As Long
    Dim old    As Long
    Dim flag    As Long
    Dim count  As Long
    Dim size    As Long
   
    ptr = lpVBHeader + &H2C
    ' Are allowed to write in the page
    VirtualProtect ByVal ptr, 4, PAGE_READWRITE, old
    ' Set a new address of Sub Main
    GetMem4 newAddress, ByVal ptr
    VirtualProtect ByVal ptr, 4, old, 0
   
    ' Remove startup form
    GetMem4 ByVal lpVBHeader + &H4C, ptr
    ' Get forms count
    GetMem4 ByVal lpVBHeader + &H44, count
   
    Do While count > 0
        ' Get structure size
        GetMem4 ByVal ptr, size
        ' Get flag (unknown5) from current form
        GetMem4 ByVal ptr + &H28, flag
        ' When set, bit 5,
        If flag And &H10 Then
            ' Unset bit 5
            flag = flag And &HFFFFFFEF
            ' Are allowed to write in the page
            VirtualProtect ByVal ptr, 4, PAGE_READWRITE, old
            ' Write changet flag
            GetMem4 flag, ByVal ptr + &H28
            ' Restoring the memory attributes
            VirtualProtect ByVal ptr, 4, old, 0
           
        End If
        count = count - 1
        ptr = ptr + size
       
    Loop
   
End Sub

Now, if you try to run this procedure before sending the header at VBDllGetClassObject, it will run the procedure defined by us. However multithreading have will work, but it is not convenient because there is no mechanism to pass a parameter to the thread as it is implemented in the CreateThread. In order to make a complete analog CreateThread I decided to create a similar function that will perform all initialization and then execute the call is transferred to the thread function with parameter. In order to be able to pass a parameter to the Sub Main, I used a thread local storage (TLS). We distinguish index for TLS. After allocation of the index, we can set the value of this index, specific for each thread. In general, the idea is, create a new thread where the starting function is a special feature ThreadProc, a parameter which transmits the structure of two fields - addresses the user function and address parameter. In this procedure, we will initialize the runtime for the new thread and stored in TLS parameter passed. As the procedure Main create a binary code that will get data from TLS, forming a stack and jump to a user function. The result had such a module:

[VB6] - Using GDI+ for generation a fir-tree.

0
0
Hello everyone! I present to you a Christmas tree generated using GDI+.
Code:

Option Explicit
' Ёлка VB6
' © Кривоус Анатолий Анатольевич (The trick), 2013
Private Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type
Private Type Vector
    x As Single
    y As Single
End Type
Private Type COLORBYTES
    BlueByte As Byte
    GreenByte As Byte
    RedByte As Byte
    AlphaByte As Byte
End Type
Private Type COLORLONG
    longval As Long
End Type
Private Type RECT
    iLeft As Long
    iTop As Long
    iRight As Long
    iBottom As Long
End Type
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, Graphics As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal Graphics As Long) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipCreatePen1 Lib "gdiplus" (ByVal color As Long, ByVal Width As Single, ByVal unit As Long, Pen As Long) As Long
Private Declare Function GdipDeletePen Lib "gdiplus" (ByVal Pen As Long) As Long
Private Declare Function GdipSetPenColor Lib "gdiplus" (ByVal Pen As Long, ByVal ARGB As Long) As Long
Private Declare Function GdipSetPenWidth Lib "gdiplus" (ByVal Pen As Long, ByVal Width As Single) As Long
Private Declare Function GdipDrawLine Lib "gdiplus" (ByVal Graphics As Long, ByVal Pen As Long, ByVal X1 As Single, ByVal Y1 As Single, ByVal X2 As Single, ByVal Y2 As Single) As Long
Private Declare Function GdipFillPolygon2 Lib "gdiplus" (ByVal Graphics As Long, ByVal Brush As Long, Points As Vector, ByVal Count As Long) As Long
Private Declare Function GdipDrawPolygon Lib "gdiplus" (ByVal Graphics As Long, ByVal Pen As Long, Points As Vector, ByVal Count As Long) As Long
Private Declare Function GdipCreateSolidFill Lib "gdiplus" (ByVal ARGB As Long, Brush As Long) As Long
Private Declare Function GdipSetSmoothingMode Lib "gdiplus" (ByVal Graphics As Long, ByVal SmoothingMd As Long) As Long
Private Declare Function GdipDeleteBrush Lib "gdiplus" (ByVal Brush As Long) As Long
Private Declare Function GdipSetSolidFillColor Lib "gdiplus" (ByVal Brush As Long, ByVal ARGB As Long) As Long
Private Declare Function GdipFillEllipse Lib "gdiplus" (ByVal Graphics As Long, ByVal Brush As Long, ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single) As Long
Private Declare Function GdipSetPathGradientCenterColor Lib "gdiplus" (ByVal Brush As Long, ByVal lColors As Long) As Long
Private Declare Function GdipSetPathGradientSurroundColorsWithCount Lib "gdiplus" (ByVal Brush As Long, ARGB As Long, Count As Long) As Long
Private Declare Function GdipSetPathGradientCenterPoint Lib "gdiplus" (ByVal Brush As Long, Points As Vector) As Long
Private Declare Function GdipCreatePathGradientFromPath Lib "gdiplus" (ByVal Path As Long, polyGradient As Long) As Long
Private Declare Function GdipDeletePath Lib "gdiplus" (ByVal Path As Long) As Long
Private Declare Function GdipCreatePath Lib "gdiplus" (ByVal brushmode As Long, Path As Long) As Long
Private Declare Function GdipAddPathEllipse Lib "gdiplus" (ByVal Path As Long, ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single) As Long
Private Declare Function GdipFillPath Lib "gdiplus" (ByVal Graphics As Long, ByVal Brush As Long, ByVal Path As Long) As Long
Private Declare Function GdipCreateBitmapFromGraphics Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, ByVal Graphics As Long, Bitmap As Long) As Long
Private Declare Function GdipDrawImage Lib "gdiplus" (ByVal Graphics As Long, ByVal image As Long, ByVal x As Single, ByVal y As Single) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
Private Declare Function GdipGraphicsClear Lib "gdiplus" (ByVal Graphics As Long, ByVal lColor As Long) As Long
Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, stride As Long, ByVal PixelFormat As Long, scan0 As Any, Bitmap As Long) As Long
Private Declare Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal image As Long, Graphics As Long) As Long
Private Declare Function UpdateLayeredWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal hdcDst As Long, pptDst As Any, psize As Any, ByVal hdcSrc As Long, pptSrc As Any, ByVal crKey As Long, pblend As Long, ByVal dwFlags As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
 
Private Const HWND_TOPMOST As Long = -1
Private Const HTCAPTION As Long = 2
Private Const WM_NCLBUTTONDOWN As Long = &HA1
Private Const SPI_GETWORKAREA = 48
Private Const WS_EX_LAYERED = &H80000
Private Const GWL_EXSTYLE As Long = -20
Private Const ULW_ALPHA = &H2
Private Const AB_32Bpp255 = 33488896
Private Const BranchCount = 25, Ratio = 2, Factor = 3
Private Const ScaleNeedles = 10, AngleNeedles = 0.45, MinBranch = 25, MaxWidth = 10, StarSize = 25, SphereSize = 10, LampSize = 8
 
Private Const UnitPixel = 2, SmoothingModeAntiAlias = 4, PixelFormat32bppARGB = &H26200A
Dim MaxLen As Single
Dim token As Long, GpInput As GdiplusStartupInput, gr As Long, gr2 As Long, pn As Long, br As Long, bg As Long
Dim Lamp() As Vector, pt() As Vector, sw As Single
Dim WithEvents Tmr As Timer
 
Private Function vec(x As Single, y As Single) As Vector: vec.x = x: vec.y = y: End Function
Private Function Lerp(x As Single, y As Single, t As Single) As Single: Lerp = x * (1 - t) + y * t: End Function
Private Sub Branch(Pos As Vector, dir As Vector, ByVal f As Long, v As Vector)
    Dim nPos As Vector, nDir As Vector, l As Single, d As Single, q As Long, p As Single, z As Single, dr As Long
    l = Sqr(dir.x * dir.x + dir.y * dir.y)
    If Abs(Pos.x - sw + dir.x) > Abs(v.x) Then v = vec(Pos.x + dir.x - sw, Pos.y + dir.y)
    GdipSetPenWidth pn, l / MaxLen * MaxWidth / 2: GdipSetPenColor pn, &H80562B00
    GdipDrawLine gr2, pn, Pos.x, Pos.y, Pos.x + dir.x, Pos.y + dir.y
    p = 1 / l * Factor
    GdipSetPenWidth pn, 1: GdipSetPenColor pn, &H80200020 Or (CLng(l / MaxLen * 128 + 127) * &H100)
    Do While d < 1
        nPos = vec(Lerp(Pos.x, Pos.x + dir.x, d), Lerp(Pos.y, Pos.y + dir.y, d))
        nDir = vec((Cos(AngleNeedles) * dir.x * d - Sin(AngleNeedles) * dir.y * d) / l * ScaleNeedles, _
                  (Sin(AngleNeedles) * dir.x * d + Cos(AngleNeedles) * dir.y * d) / l * ScaleNeedles)
        GdipDrawLine gr2, pn, nPos.x, nPos.y, nPos.x + nDir.x, nPos.y + nDir.y
        nDir = vec((Cos(-AngleNeedles) * dir.x * d - Sin(-AngleNeedles) * dir.y * d) / l * ScaleNeedles, _
                  (Sin(-AngleNeedles) * dir.x * d + Cos(-AngleNeedles) * dir.y * d) / l * ScaleNeedles)
        GdipDrawLine gr2, pn, nPos.x, nPos.y, nPos.x + nDir.x, nPos.y + nDir.y
        d = d + p
    Loop
    If l < MinBranch Or f > 3 Then Exit Sub
    q = Rnd * 4 + 2: p = 1 / (q - 1): d = 0
    Do While q > 0
        nPos = vec(Lerp(Pos.x, Pos.x + dir.x, d), Lerp(Pos.y, Pos.y + dir.y, d))
        z = z + p: d = Rnd * 0.35 + 0.275: dr = 2
        Do While dr
            nDir = vec((Cos(d) * dir.x - Sin(d) * dir.y) / Ratio, (Sin(d) * dir.x + Cos(d) * dir.y) / Ratio)
            Branch nPos, nDir, f + 1, v: dr = dr - 1: d = -d
        Loop
        q = q - 1
    Loop
End Sub
Private Sub Form_DblClick()
    Unload Me
End Sub
Private Sub Form_Load()
    Dim n As Long, dy As Single, dx As Single, oy As Single, br2 As Long
    Dim Pth As Long, Col As Long, sp() As Vector, v As Vector, rc As RECT
    If SystemParametersInfo(SPI_GETWORKAREA, 0, rc, 0) = 0 Then End
    SetWindowPos Me.hWnd, HWND_TOPMOST, rc.iRight - 293, rc.iBottom - 336, 293, 336, 0
    GpInput.GdiplusVersion = 1
    If GdiplusStartup(token, GpInput) Then End
    If GdipCreateFromHDC(Me.hdc, gr) Then Unload Me
    If GdipCreateSolidFill(&HFF562B00, br) Then Unload Me
    If GdipCreatePen1(&HFF562B00, 1, UnitPixel, pn) Then Unload Me
    If GdipCreateBitmapFromScan0(Me.ScaleWidth, Me.ScaleHeight, Me.ScaleWidth * 4, PixelFormat32bppARGB, ByVal 0, bg) Then Unload Me
    If GdipGetImageGraphicsContext(bg, gr2) Then Unload Me
    If GdipSetSmoothingMode(gr, SmoothingModeAntiAlias) Then Unload Me
    If GdipSetSmoothingMode(gr2, SmoothingModeAntiAlias) Then Unload Me
    Set Tmr = Me.Controls.Add("VB.Timer", "Tmr")
    ReDim pt(BranchCount * 2 - 1): ReDim Lamp(BranchCount \ 3 - 2): ReDim sp(BranchCount \ 4 - 1)
    n = Me.ScaleWidth / 3: dy = Me.ScaleHeight / BranchCount / 1.4: sw = Me.ScaleWidth / 2
    dx = n / BranchCount: oy = Me.ScaleHeight * 0.25: MaxLen = Sqr(n * n + 30 * 30)
    pt(0) = vec(sw, oy): pt(1) = vec(Me.ScaleWidth / 2 - 8, Me.ScaleHeight): pt(2) = vec(sw + 8, pt(1).y)
    GdipFillPolygon2 gr2, br, pt(0), 3
    Branch vec(sw, oy + Me.ScaleHeight / 1.5), vec(0, -Me.ScaleHeight / 3), 0, vec(0, 0)
    For n = 0 To BranchCount - 1
        pt(n * 2) = vec(0, 0): pt(n * 2 + 1) = vec(0, 0)
        Call Branch(vec(sw, n * dy + oy), vec(-dx * n, -30), 0, pt(n * 2)): pt(n * 2).x = pt(n * 2).x + sw
        Call Branch(vec(sw, n * dy + oy), vec(dx * n, -30), 0, pt(n * 2 + 1)): pt(n * 2 + 1).x = pt(n * 2 + 1).x + sw
        If n Mod 3 = 0 And n > 1 And n < BranchCount - 1 Then Lamp((n - 1) \ 3) = pt(n * 2)
        If n Mod 4 = 0 And n > 1 Then sp((n - 1) \ 4) = pt(n * 2 + 1)
    Next
    For n = 0 To UBound(sp): dy = (sp(n).x - sw): For dx = 0 To dy Step 10
        v = vec(Lerp(sp(n).x, sw - dy, dx / dy), Lerp(sp(n).y, sp(n).y + 10, Sin(dx / dy * 3.14) * (dy / MaxLen) * 2))
        GdipCreatePath 0, Pth
        GdipAddPathEllipse Pth, v.x - SphereSize, v.y - SphereSize / 2, SphereSize, SphereSize
        GdipCreatePathGradientFromPath Pth, br2
        GdipSetPathGradientCenterPoint br2, vec(v.x - SphereSize / 3, v.y - SphereSize / 3)
        Col = QBColor(Rnd * 15)
        GdipSetPathGradientCenterColor br2, ARGB(255, vbWhite)
        GdipSetPathGradientSurroundColorsWithCount br2, ARGB(64, Col), 1
        GdipFillPath gr2, br2, Pth: GdipDeleteBrush br2: GdipDeletePath Pth
    Next: Next
    dx = 2.199
    For n = 0 To 9 Step 2
        pt(n) = vec(Cos(dx) * StarSize + Me.ScaleWidth / 2, Sin(dx) * StarSize + oy - StarSize - 15): dx = dx + 0.628
        pt(n + 1) = vec(Cos(dx) * StarSize / 2 + Me.ScaleWidth / 2, Sin(dx) * StarSize / 2 + oy - StarSize - 15): dx = dx + 0.628
    Next
    SetWindowLong Me.hWnd, GWL_EXSTYLE, GetWindowLong(Me.hWnd, GWL_EXSTYLE) Or WS_EX_LAYERED
    Tmr.Enabled = True: Tmr.Interval = 32: Call Tmr_Timer
End Sub
 
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    ReleaseCapture
    SendMessage Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    If pn Then GdipDeletePen (pn)
    If br Then GdipDeleteBrush (br)
    If gr Then GdipDeleteGraphics (gr)
    If gr2 Then GdipDeleteGraphics (gr2)
    If bg Then GdipDisposeImage (bg)
    GdiplusShutdown (token)
End Sub
Private Sub Tmr_Timer()
    Static n As Long, c As Long, d As Single, x As Long, y As Long, dx As Single, Pth As Long, br2 As Long, v As Vector, _
        Col As Long, B As Single, s As Single, dir As Single, sz As Currency, pts As Currency
    d = Sin(c / 10): c = (c + 1) Mod 31: dir = 1
    GdipGraphicsClear gr, &HFF000000
    GdipDrawImage gr, bg, 0, 0
    GdipSetSolidFillColor br, ARGB(d * 128 + 127, vbBlue): GdipSetPenWidth pn, 1: GdipSetPenColor pn, &HFFFF5050
    GdipFillPolygon2 gr, br, pt(0), 10
    GdipDrawPolygon gr, pn, pt(0), 10
    For n = 0 To 9
        GdipDrawLine gr, pn, Me.ScaleWidth / 2, Me.ScaleHeight * 0.25 - StarSize - 15, pt(n).x, pt(n).y
    Next
    For n = 0 To UBound(Lamp): d = sw - Lamp(n).x: dir = -dir: For x = 0 To d Step 2
        B = Abs(Sin(s))
        v = vec(Lerp(Lamp(n).x, sw + d, x / d), Lerp(Lamp(n).y, Lamp(n).y + 10, Sin(x / d * 3.14) * (d / MaxLen) * 3))
        GdipCreatePath 0, Pth
        GdipAddPathEllipse Pth, v.x - LampSize / 2, v.y - LampSize / 2, LampSize, LampSize
        GdipCreatePathGradientFromPath Pth, br2
        GdipSetPathGradientCenterPoint br2, vec(v.x, v.y)
        GdipSetPathGradientCenterColor br2, ARGB(B * 255, vbCyan)
        GdipSetPathGradientSurroundColorsWithCount br2, 0, 1
        GdipFillPath gr, br2, Pth: GdipDeleteBrush br2: GdipDeletePath Pth
        s = s + 2 * dir
    Next:  Next
    Me.Refresh
    sz = (Me.ScaleWidth + CCur(Me.ScaleHeight) * 4294967296#) / 10000
    UpdateLayeredWindow Me.hWnd, Me.hdc, ByVal 0, sz, Me.hdc, pts, 0, AB_32Bpp255, ULW_ALPHA
End Sub
Public Function ARGB(ByVal Alpha As Byte, Col As Long) As Long
  Dim bytestruct As COLORBYTES
  Dim result As COLORLONG
  With bytestruct
      .AlphaByte = Alpha
      .RedByte = (Col And &HFF0000) \ &H10000
      .GreenByte = (Col And &HFF00&) \ &H100
      .BlueByte = (Col And &HFF)
  End With
  LSet result = bytestruct
  ARGB = result.longval
End Function

Attached Files

[VB6] - Vocoder.

0
0
Hello everyone. Creating music, I've seen a lot of different virtual instruments and effects. One of the most interesting effects is the vocoder, which allows you to modulate his voice and make it look like a voice for example a robot or something like that. Vocoder was originally used to compress the voice data, and then it began to be used in the music industry. Because I had free time, I decided to write something like this for the sake of the experiment and describe in detail the stages of development for VB6.
So, take a look at the simplest scheme vocoder:

The signal from the microphone (speech) is fed to a bank of bandpass filters, each of which passes only a small part of the frequency band of the speech signal. The greater the number of filters - the better speech intelligibility. At the same time, the carrier signal (e.g. ramp) is also passed through the same filter bank. Filter output speech signal is fed to envelope detectors which control modulators and outputs a filter carrier signal passes to the other input of the modulator. As a result, each band speech signal adjusts the level of the corresponding band carrier (modulates it). Further, output signals from all modulators are mixed and sent to the output. Further, all signal modulators are mixed and sent to the output. In order to improve speech intelligibility also apply additional blocks, such as the detector "sizzling" sound. So, to begin development necessary to determine the source signals, where they will take. It is possible for example to capture data from a file or directly processed in real-time from a microphone or line input. To test very easy to use file, so we will do and so and so. As the carrier will use an external file looped in a circle, to adjust the tone simply add the ability to change the playback speed, which will change the tone. To capture the sound of the file will use Audio Compression Manager (ACM), with it very convenient to make conversion between formats (because the file can be in any format, you would have to write some functions to different formats). It may be that to convert to the desired format will not correct ACM drivers, then play this file will not be available (although you can try to do it in 2 stages). As input files will use the wav - files, because to work with them in the system has special features to facilitate retrieving data from them.

[VB6] - Rotation a windowless controls.

0
0
Code:

Option Explicit

Private Type XFORM
  eM11 As Single
  eM12 As Single
  eM21 As Single
  eM22 As Single
  eDx As Single
  eDy As Single
End Type

Private Declare Function SetGraphicsMode Lib "gdi32" (ByVal hdc As Long, ByVal iMode As Long) As Long
Private Declare Function SetWorldTransform Lib "gdi32" (ByVal hdc As Long, lpXform As XFORM) As Long
Private Declare Function ModifyWorldTransform Lib "gdi32" (ByVal hdc As Long, lpXform As XFORM, ByVal iMode As Long) As Long
Private Const MWT_IDENTITY = 1
Private Const MWT_LEFTMULTIPLY = 2
Private Const MWT_RIGHTMULTIPLY = 3

Private Const GM_ADVANCED = 2
Private Const GM_COMPATIBLE = 1

Private Sub Form_Load()
    SetGraphicsMode Me.hdc, GM_ADVANCED
End Sub

Private Sub Form_Paint()
    Dim mtx1 As XFORM, mtx2 As XFORM, c As Single, s As Single, p As IPicture
    ModifyWorldTransform Me.hdc, mtx1, MWT_IDENTITY
    Me.Line (0, 0)-(Me.ScaleWidth, Me.ScaleHeight), Me.BackColor, BF
    c = Cos(hsbAngle.Value / 100)
    s = Sin(hsbAngle.Value / 100)
    mtx1.eM11 = c: mtx1.eM12 = s: mtx1.eM21 = -s: mtx1.eM22 = c: mtx1.eDx = Me.ScaleWidth / 2: mtx1.eDy = Me.ScaleHeight / 2
    mtx2.eM11 = 1: mtx2.eM22 = 1: mtx2.eDx = -Me.ScaleWidth / 2: mtx2.eDy = -Me.ScaleHeight / 2
    SetWorldTransform Me.hdc, mtx1
    ModifyWorldTransform Me.hdc, mtx2, MWT_LEFTMULTIPLY
End Sub

Private Sub hsbAngle_Change()
    Me.Refresh
End Sub

Attached Files

[VB6] - Module with advanced mathematical functions for real and complex numbers.

0
0
Code:

'+=====================================================================================================================================+
'|                                                                                                                                    |
'|                                    An additional set of mathematical functions for Visual Basic 6                                  |
'|                                                                                                                                    |
'|                                          Кривоус Анатолий Анатольевич (The trick)                                                  |
'|                                                                                                                                    |
'+=====================================================================================================================================+

Private Declare Function GetMem2 Lib "msvbvm60" (pSrc As Any, pDst As Any) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (pSrc As Any, pDst As Any) As Long
Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (arr() As Any) As Long

Public Type Complex
    R  As Double
    I  As Double
End Type

Public Type Matrix
    Col As Long                ' Number of columns
    Row As Long                ' Number of rows
    D() As Double
End Type

Public Const PI = 3.14159265358979
Public Const E = 2.71828182845905

Private Const PI2 = PI / 2

'+=====================================================================================================================================+
'|                                                            Real numbers                                                            |
'+=====================================================================================================================================+

' // From degree to radians
Public Function Deg(ByVal Value As Double) As Double
    Deg = 1.74532925199433E-02 * Value
End Function

' // The logarithm to the base of a real number X
Public Function LogX(ByVal Value As Double, ByVal Base As Double) As Double
    LogX = Log(Value) / Log(Base)
End Function

' // The decimal logarithm of a real number
Public Function Log10(ByVal Value As Double) As Double
    Log10 = Log(Value) / 2.30258509299405
End Function

' // The binary logarithm of a real number
Public Function Log2(ByVal Value As Double) As Double
    Log2 = Log(Value) / 0.693147180559945
End Function

' // Rounding up
Public Function Ceil(ByVal Value As Double) As Double
    Ceil = -Int(-Value)
End Function

' // Rounding down (Int)
Public Function Floor(ByVal Value As Double) As Double
    Floor = Int(Value)
End Function

' // Secant of a real number
Public Function Sec(ByVal Value As Double) As Double
    Sec = 1 / Cos(Value)
End Function

' // Cosecant of a real number
Public Function Csc(ByVal Value As Double) As Double
    Csc = 1 / Sin(Value)
End Function

' // Cotangent of a real number
Public Function Ctg(ByVal Value As Double) As Double
    Ctg = 1 / Tan(Value)
End Function

' // Arcsine of a real number
Public Function Asin(ByVal Value As Double) As Double
    If Value = -1 Then Asin = -PI2: Exit Function
    If Value = 1 Then Asin = PI2: Exit Function
    Asin = Atn(Value / Sqr(-Value * Value + 1))
End Function

' // Arccosine of a real number
Public Function Acos(ByVal Value As Double) As Double
    If CSng(Value) = -1# Then Acos = PI: Exit Function
    If CSng(Value) = 1# Then Acos = 0: Exit Function
    Acos = Atn(-Value / Sqr(-Value * Value + 1)) + 2 * Atn(1)
End Function

' // Arcsecant of a real number
Public Function Asec(ByVal Value As Double) As Double
    Asec = 1.5707963267949 - Atn(Sgn(Value) / Sqr(Value * Value - 1))
End Function

' // Arccosecant of a real number
Public Function Acsc(ByVal Value As Double) As Double
    Acsc = Atn(Sgn(Value) / Sqr(Value * Value - 1))
End Function

' // Returns the angle whose tangent is the ratio of the two numbers
Public Function Atan2(ByVal Y As Double, ByVal X As Double) As Double
    If Y > 0 Then
        If X >= Y Then
            Atan2 = Atn(Y / X)
        ElseIf X <= -Y Then
            Atan2 = Atn(Y / X) + PI
        Else
            Atan2 = PI / 2 - Atn(X / Y)
        End If
    Else
        If X >= -Y Then
            Atan2 = Atn(Y / X)
        ElseIf X <= Y Then
            Atan2 = Atn(Y / X) - PI
        Else
            Atan2 = -Atn(X / Y) - PI / 2
        End If
    End If
End Function

' // Arccotangent of a real number
Public Function Actg(ByVal Value As Double) As Double
    Actg = 1.5707963267949 - Atn(Value)
End Function

' // Hyperbolic sine of a real number
Public Function Sinh(ByVal Value As Double) As Double
    Sinh = (Exp(Value) - Exp(-Value)) / 2
End Function

' // Hyperbolic cosine of a real number
Public Function Cosh(ByVal Value As Double) As Double
    Cosh = (Exp(Value) + Exp(-Value)) / 2
End Function

' // Hyperbolic tangent of a real number
Public Function Tanh(ByVal Value As Double) As Double
    Tanh = (Exp(2 * Value) - 1) / (Exp(2 * Value) + 1)
End Function

' // Hyperbolic cotangent of a real number
Public Function Ctgh(ByVal Value As Double) As Double
    Ctgh = 1 / (Exp(2 * Value) + 1) / (Exp(2 * Value) - 1)
End Function

' // Hyperbolic secant of a real number
Public Function Sech(ByVal Value As Double) As Double
    Sech = 2 / (Exp(Value) + Exp(-Value))
End Function

' // Hyperbolic cosecant of a real number
Public Function Csch(ByVal Value As Double) As Double
    Csch = 2 / (Exp(Value) - Exp(-Value))
End Function

' // Hyperbolic arcsine of a real number
Public Function Asinh(ByVal Value As Double) As Double
    Asinh = Log(Value + Sqr(Value * Value + 1))
End Function

' // Hyperbolic arcosine of a real number
Public Function Acosh(ByVal Value As Double) As Double
    Acosh = Log(Value + Sqr(Value * Value - 1))
End Function

' // Hyperbolic arctangent of a real number
Public Function Atanh(ByVal Value As Double) As Double
    Atanh = Log((1 + Value) / (1 - Value)) / 2
End Function

' // Hyperbolic arccotangent of a real number
Public Function Actan(ByVal Value As Double) As Double
    Actan = Log((Value + 1) / (Value - 1)) / 2
End Function

' // Hyperbolic arcsecant of a real number
Public Function Asech(ByVal Value As Double) As Double
    Asech = Log((Sqr(-Value * Value + 1) + 1) / Value)
End Function

' // Hyperbolic arccosecant of a real number
Public Function Acsch(ByVal Value As Double) As Double
    Acsch = Log((Sgn(Value) * Sqr(Value * Value + 1) + 1) / Value)
End Function

' // Return maximum of two numbers
Public Function Max(ByVal Op1 As Double, ByVal Op2 As Double) As Double
    Max = IIf(Op1 > Op2, Op1, Op2)
End Function

' // Return maximum of three numbers
Public Function Max3(ByVal Op1 As Double, ByVal Op2 As Double, ByVal Op3 As Double) As Double
    Max3 = IIf(Op1 > Op2, IIf(Op1 > Op3, Op1, Op3), IIf(Op2 > Op3, Op2, Op3))
End Function

' // Return maximum of four numbers
Public Function Max4(ByVal Op1 As Double, ByVal Op2 As Double, ByVal Op3 As Double, ByVal Op4 As Double) As Double
    Max4 = Max(Max3(Op1, Op2, Op3), Op4)
End Function

' // Return minimum of two numbers
Public Function Min(ByVal Op1 As Double, ByVal Op2 As Double) As Double
    Min = IIf(Op1 < Op2, Op1, Op2)
End Function

' // Return minimum of three numbers
Public Function Min3(ByVal Op1 As Double, ByVal Op2 As Double, ByVal Op3 As Double) As Double
    Min3 = IIf(Op1 < Op2, IIf(Op1 < Op3, Op1, Op3), IIf(Op2 < Op3, Op2, Op3))
End Function

' // Return minimum of four numbers
Public Function Min4(ByVal Op1 As Double, ByVal Op2 As Double, ByVal Op3 As Double, ByVal Op4 As Double) As Double
    Min4 = Min(Min3(Op1, Op2, Op3), Op4)
End Function

' // Returns the remainder of dividing one specified number by another specified number.
Public Function IEEERemainder(ByVal Op1 As Double, ByVal Op2 As Double) As Double
    IEEERemainder = Op1 - (Op2 * Round(Op1 / Op2))
End Function

' // Returns the remainder of dividing one specified number by another specified number.
Public Function rMod(ByVal Op1 As Double, ByVal Op2 As Double) As Double
    rMod = (Abs(Op1) - (Abs(Op2) * (Int(Abs(Op1) / Abs(Op2))))) * Sgn(Op1)
End Function

Unhighlighting ComboBox, DropdownCombo text in VB6

0
0
Although it is a minor aesthetic issue, when I have a dropdown list I do not like to see the text highlighted either at the program start or after selecting a list item. Most of the time I also have the keypress() method set keyascii to 0 as I rarely use these as input fields. Below is the code that uses a timer control as a one-shot outside of the list box execution: It is fast, keeps the focus in the list control and does not use cycles unless it actually needs to clear the highlight.



Code:

Public Sub uhl(index As Integer)
'//////////////////////////////////////////////////////////////////////////////
'This un-highlights the text in ComboBox controls set as a DropdownCombo.  It
'only works on a "DropdownCombo" because the "DropdownList" does not actually
'have the SelLength property.  The timer is set to 1mS and is active only
'once per list box event (As opposed to constantly monitoring/unhighlighting
'the list box:  This would not do for real time loaded apps!)
'
'Put "Call uhl(index)" in the click(), change(), dbl_click(), got_focus() and
'scroll() methods of any combo lists to un-highlight.
'
'(index) tells uhl() which control to update.
'
'This needs to be done as the last external execution of these methods as any
'call outside of the method re-highlights the text on its return as if it was
'a new got focus event.
'//////////////////////////////////////////////////////////////////////////////
Static uhlindex As Integer
Select Case index
  Case -1
    'Called by the timer, this is not called by the list box and so can
    'actually unhighlight the text.
    Select Case uhlindex
      Case 0
        combo0.SelLength = 0
      Case 1
        combo1.SelLength = 0
    End Select
    'the timer is turned off
    uhltimer.Enabled = False
  Case Else
    'Called by the list box, this saves the index and enables the timer.
    'This essentially triggers an independent process outside of the list box
    'to do the un-highlight.
    'save the index
    uhlindex = index
    'set the timer interval to 1ms and turn it on
    uhltimer.Interval = 1
    uhltimer.Enabled = True
End Select
End Sub


Private Sub uhltimer_Timer()
'This calls another instance of UHL() to do the actual un-highlighting
Call uhl(-1)
End Sub

Unhighlighting ComboBox, DropdownCombo text in VB6 SP3

0
0
'Although it is a minor aesthetic issue, when I have a dropdown list I do
'not like to see the text highlighted either at the program start or after
'selecting a list item. Most of the time I also have the keypress() method
'set keyascii to 0 as I rarely use these as input fields. Below is the code
'that uses a timer control as a one-shot outside of the list box execution:
'It is fast, keeps the focus in the list control and does not use cycles unless
'it actually needs to clear the highlight.



Public Sub uhl(index As Integer)
'//////////////////////////////////////////////////////////////////////////////
'This un-highlights the text in ComboBox controls set as a DropdownCombo. It
'only works on a "DropdownCombo" because the "DropdownList" does not actually
'have the SelLength property. The timer is set to 1mS and is active only
'once per list box event (As opposed to constantly monitoring/unhighlighting
'the list box: This would not do for real time loaded apps!)
'
'Put "Call uhl(index)" in the click(), change(), dbl_click(), got_focus() and
'scroll() methods of any combo lists to un-highlight.
'
'(index) tells uhl() which control to update.
'
'This needs to be done as the last external execution of these methods as any
'call outside of the method re-highlights the text on its return as if it was
'a new got focus event.
'//////////////////////////////////////////////////////////////////////////////
Static uhlindex As Integer
Select Case index
Case -1
'Called by the timer, this is not called by the list box and so can
'actually unhighlight the text.
Select Case uhlindex
Case 0
combo0.SelLength = 0
Case 1
combo1.SelLength = 0
End Select
'the timer is turned off
uhltimer.Enabled = False
Case Else
'Called by the list box, this saves the index and enables the timer.
'This essentially triggers an independent process outside of the list box
'to do the un-highlight.
'save the index
uhlindex = index
'set the timer interval to 1ms and turn it on
uhltimer.Interval = 1
uhltimer.Enabled = True
End Select
End Sub


Private Sub uhltimer_Timer()
'This calls another instance of UHL() to do the actual un-highlighting
Call uhl(-1)
End Sub

[VB6] - Combobox for color selection.

0
0
Standard VB combo box does not allow standard means to draw on the list. To work around this limitation, in its module I use OWNERDRAW style combo box. After small completion, you can do anything with the list.
Code:

Option Explicit
 
' Модуль для создания комбинированного списка с выбором цветов
' © Кривоус Анатолий Анатольевич (The trick), 2014
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type DRAWITEMSTRUCT
    CtlType As Long
    CtlID As Long
    itemID As Long
    itemAction As Long
    itemState As Long
    hwndItem As Long
    hdc As Long
    rcItem As RECT
    itemData As Long
End Type
Private Type MEASUREITEMSTRUCT
    CtlType As Long
    CtlID As Long
    itemID As Long
    itemWidth As Long
    itemHeight As Long
    itemData As Long
End Type
 
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function SetDCBrushColor Lib "gdi32" (ByVal hdc As Long, ByVal colorref As Long) As Long
Private Declare Function SetDCPenColor Lib "gdi32" (ByVal hdc As Long, ByVal colorref As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, lpStr As Any, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
 
Private Const TRANSPARENT As Long = 1
Private Const COLOR_WINDOW As Long = 5
Private Const COLOR_WINDOWTEXT As Long = 8
Private Const COLOR_HIGHLIGHT As Long = 13
Private Const COLOR_HIGHLIGHTTEXT As Long = 14
Private Const ODS_SELECTED As Long = &H1
Private Const DC_PEN As Long = 19
Private Const DC_BRUSH As Long = 18
Private Const WH_CBT As Long = 5
Private Const HCBT_CREATEWND As Long = 3
Private Const GWL_WNDPROC = &HFFFFFFFC
Private Const ODT_COMBOBOX As Long = 3
Private Const CBS_OWNERDRAWFIXED As Long = &H10&
Private Const CBS_DROPDOWNLIST As Long = &H3&
Private Const CBS_HASSTRINGS As Long = &H200&
Private Const WM_MEASUREITEM As Long = &H2C
Private Const WM_DRAWITEM = &H2B
Private Const GWL_STYLE As Long = &HFFFFFFF0
Private Const WM_DESTROY As Long = &H2
Private Const DT_SINGLELINE As Long = &H20, DT_VCENTER As Long = &H4
Private Const CB_GETLBTEXT As Long = &H148
Private Const CB_GETLBTEXTLEN As Long = &H149
 
Dim hHook As Long
 
Public Function CreateOwnerdrawCombo(Form As Form, Name As String, Optional Container As Control) As ComboBox
    Dim Prev As Long
    hHook = SetWindowsHookEx(WH_CBT, AddressOf CBTProc, 0, App.ThreadID)
    If Container Is Nothing Then
        Set CreateOwnerdrawCombo = Form.Controls.Add("VB.ComboBox", Name)
    Else: Set CreateOwnerdrawCombo = Form.Controls.Add("VB.ComboBox", Name, Container)
    End If
    UnhookWindowsHookEx hHook
    If Not CreateOwnerdrawCombo Is Nothing Then
        Prev = GetProp(CreateOwnerdrawCombo.Container.hwnd, "prev")
        If Prev = 0 Then
            Prev = SetWindowLong(CreateOwnerdrawCombo.Container.hwnd, GWL_WNDPROC, AddressOf WndProc)
            SetProp CreateOwnerdrawCombo.Container.hwnd, "prev", Prev
        End If
    End If
End Function
Private Function CBTProc(ByVal uCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If uCode = HCBT_CREATEWND Then
        Dim Class As String, l As Long, Style As Long
        Class = Space(256)
        l = GetClassName(wParam, Class, 255)
        If l Then
            Class = Left(Class, l)
            If StrComp(Class, "ThunderComboBox", vbTextCompare) = 0 Or _
              StrComp(Class, "ThunderRT6ComboBox", vbTextCompare) = 0 Then
                Style = GetWindowLong(wParam, GWL_STYLE)
                SetWindowLong wParam, GWL_STYLE, Style Or CBS_OWNERDRAWFIXED Or CBS_DROPDOWNLIST Or CBS_HASSTRINGS
            End If
        End If
    End If
    CBTProc = CallNextHookEx(hHook, uCode, wParam, ByVal lParam)
End Function
Private Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim Prev As Long
    Select Case uMsg
    Case WM_DESTROY
        Prev = GetProp(hwnd, "prev")
        SetWindowLong hwnd, GWL_WNDPROC, Prev
        RemoveProp hwnd, "prev"
        WndProc = CallWindowProc(Prev, hwnd, uMsg, wParam, lParam)
    Case WM_DRAWITEM
        Dim drw As DRAWITEMSTRUCT
        CopyMemory drw, ByVal lParam, Len(drw)
        If drw.CtlType = ODT_COMBOBOX Then
            DrawItem drw
            WndProc = True
        Else
            Prev = GetProp(hwnd, "prev")
            WndProc = CallWindowProc(Prev, hwnd, uMsg, wParam, lParam)
        End If
    Case WM_MEASUREITEM
        Dim meas As MEASUREITEMSTRUCT, RC As RECT
        CopyMemory meas, ByVal lParam, Len(meas)
        If meas.CtlType = ODT_COMBOBOX Then
            GetClientRect hwnd, RC
            meas.itemWidth = RC.Right - RC.Left
            CopyMemory ByVal lParam, meas, Len(meas)
            WndProc = True
        Else
            Prev = GetProp(hwnd, "prev")
            WndProc = CallWindowProc(Prev, hwnd, uMsg, wParam, lParam)
        End If
    Case Else
        Prev = GetProp(hwnd, "prev")
        WndProc = CallWindowProc(Prev, hwnd, uMsg, wParam, lParam)
    End Select
End Function
 
Private Function DrawItem(drw As DRAWITEMSTRUCT) As Boolean
    Dim obr As Long, opn As Long, l As Long, s As String
    obr = SelectObject(drw.hdc, GetStockObject(DC_BRUSH))
    opn = SelectObject(drw.hdc, GetStockObject(DC_PEN))
    If (drw.itemState And ODS_SELECTED) Then
        SetDCBrushColor drw.hdc, GetSysColor(COLOR_HIGHLIGHT)
        SetDCPenColor drw.hdc, GetSysColor(COLOR_HIGHLIGHT)
        Rectangle drw.hdc, drw.rcItem.Left, drw.rcItem.Top, drw.rcItem.Right, drw.rcItem.Bottom
        SetDCPenColor drw.hdc, GetSysColor(COLOR_HIGHLIGHTTEXT)
        SetTextColor drw.hdc, GetSysColor(COLOR_HIGHLIGHTTEXT)
    Else
        SetDCBrushColor drw.hdc, GetSysColor(COLOR_WINDOW)
        SetDCPenColor drw.hdc, GetSysColor(COLOR_WINDOW)
        Rectangle drw.hdc, drw.rcItem.Left, drw.rcItem.Top, drw.rcItem.Right, drw.rcItem.Bottom
        SetDCPenColor drw.hdc, GetSysColor(COLOR_WINDOWTEXT)
        SetTextColor drw.hdc, GetSysColor(COLOR_WINDOWTEXT)
    End If
    SetBkMode drw.hdc, TRANSPARENT
    If drw.itemID >= 0 Then
        SetDCBrushColor drw.hdc, drw.itemData
        Rectangle drw.hdc, drw.rcItem.Left + 3, drw.rcItem.Top + 3, drw.rcItem.Left + 70, drw.rcItem.Bottom - 3
        l = SendMessage(drw.hwndItem, CB_GETLBTEXTLEN, drw.itemID, ByVal 0)
        If l Then
            s = Space(l + 1)
            l = SendMessage(drw.hwndItem, CB_GETLBTEXT, drw.itemID, ByVal s)
            s = Left(s, l)
            drw.rcItem.Left = drw.rcItem.Left + 78
        End If
    Else
        drw.rcItem.Left = drw.rcItem.Left + 2
        s = "None"
    End If
    DrawText drw.hdc, ByVal s, Len(s), drw.rcItem, DT_VCENTER Or DT_SINGLELINE
    SelectObject drw.hdc, obr
    SelectObject drw.hdc, opn
End Function

Attached Files

[VB6] - Circular spectrum visualizer.

0
0

Hello everyone! Representing the source code and compiled program graphical visualizer audio spectrum. The sound is analyzed through a standard recording device, i.e. You can select the microphone and view range with it, or you can select stereo mixer and view the range of playback sound. In this visualizer is possible to adjust the number of displayed octaves, adjustable transparency background, amplification. You can also loading a palette of external PNG file format 32ARGB, damping effects "blur" and "burning". Visualizer allows viewing range in two modes as arcs (rings) in the form of sectors. In the first form of the radial coordinate is responsible for the frequency octave, corner - between octaves. Harmonics are separated from each other by an octave, are on the same line, color - intensity. In the second mode, the radial coordinate - the volume, color - frequency, angular coordinate - frequency (period - 1 octave). This idea was suggested to me Vladislav Petrovky (aka Hacker), only his idea a little differently had displayed spectrum as a curve, I have done in the form of sectors.

modAudio.bas module:
Code:

Option Explicit
 
' Модуль modAudio.bas для захвата звука в программе TrickSpectrum
' © Кривоус Анатолий Анатольевич (The trick), 2014
 
Public Type WAVEFORMATEX                                        ' Структура формата аудио
    wFormatTag As Integer                                      ' Тип
    nChannels As Integer                                        ' Кол-во каналов
    nSamplesPerSec As Long                                      ' Частота дискретизации
    nAvgBytesPerSec As Long                                    ' Количество байт в секунду
    nBlockAlign As Integer                                      ' Выравнивание бока данных в байтах
    wBitsPerSample As Integer                                  ' Байт на выборку
    cbSize As Integer                                          ' Размер доп. данных
End Type
 
Public Type WAVEHDR                                            ' Структура заголовка буфера
    lpData As Long                                              ' Указатель на данные буфера
    dwBufferLength As Long                                      ' Размер буфера в байтах
    dwBytesRecorded As Long                                    ' Количество записанных байтов
    dwUser As Long                                              ' Данные пользователя
    dwFlags As Long                                            ' Флаги
    dwLoops As Long                                            ' Количество закольцованнх проигрываний
    lpNext As Long
    Reserved  As Long
End Type
 
Public Type BUFFER                                              ' Структура буфера
    Data() As Integer                                          ' Данные
    Header As WAVEHDR                                          ' Заголовок
End Type
 
Public Declare Function waveInOpen Lib "winmm.dll" (lphWaveIn As Long, ByVal uDeviceID As Long, lpFormat As WAVEFORMATEX, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Public Declare Function waveInPrepareHeader Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long
Public Declare Function waveInReset Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Public Declare Function waveInStart Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Public Declare Function waveInStop Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Public Declare Function waveInUnprepareHeader Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long
Public Declare Function waveInClose Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Public Declare Function waveInGetErrorText Lib "winmm.dll" Alias "waveInGetErrorTextA" (ByVal err As Long, ByVal lpText As String, ByVal uSize As Long) As Long
Public Declare Function waveInAddBuffer Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long
 
Public Const mSampleRate As Long = 44100                        ' Частота дискретизации
Public Const BufSizeMS As Single = 0.03                        ' Размер буфера в секундах
 
Public Const WAVE_MAPPER = -1&
Public Const CALLBACK_WINDOW = &H10000
Public Const WAVE_FORMAT_PCM = 1
Public Const MM_WIM_DATA = &H3C0
 
Dim hWave As Long                                              ' Дескриптор записывающего устройства
Dim Fmt As WAVEFORMATEX                                        ' Формат записи
Dim Buffers() As BUFFER                                        ' Буферы
 
' Функция инициализирует запись
Public Function InitCapture() As Boolean
    Dim ret As Long, msg As String, i As Long, count As Long
   
    ' Задаем формат записи
    With Fmt
        .cbSize = 0
        .wFormatTag = WAVE_FORMAT_PCM
        .wBitsPerSample = 16
        .nSamplesPerSec = mSampleRate
        .nChannels = 2
        .nBlockAlign = .nChannels * .wBitsPerSample / 8
        .nAvgBytesPerSec = .nSamplesPerSec * .nBlockAlign
    End With
   
    ' Вычисляем размер буфера в выборках
    count = Fmt.nAvgBytesPerSec * BufSizeMS
    count = count - (count Mod Fmt.nBlockAlign)
   
    ' Открываем устройство записи
    ret = waveInOpen(hWave, WAVE_MAPPER, Fmt, frmMain.hwnd, 0, CALLBACK_WINDOW)
   
    If ret Then ShowMessage ret: Exit Function
   
    ' 4 буфера
    ReDim Buffers(3)
   
    ' Подготовка буферов
    For i = 0 To UBound(Buffers)
        With Buffers(i)
            ReDim .Data(count - 1)
            .Header.lpData = VarPtr(.Data(0))
            .Header.dwBufferLength = count * 2
            .Header.dwFlags = 0
            .Header.dwLoops = 0
            ret = waveInPrepareHeader(hWave, .Header, Len(.Header))
            If ret Then ShowMessage ret: Exit Function
        End With
    Next i
   
    ' Отправка буферов устройству
    For i = 0 To UBound(Buffers)
        ret = waveInAddBuffer(hWave, Buffers(i).Header, Len(Buffers(i).Header))
        If ret Then ShowMessage ret: Exit Function
    Next i
   
    ' Начинаем запись
    ret = waveInStart(hWave)
    If ret Then ShowMessage ret: Exit Function
   
    ' Успешно
    InitCapture = True
End Function
 
' Процедура останавливает запись
Public Sub EndCapture()
    Dim i As Long
    ' Сброс устройства и возвращение всех буферов приложению
    waveInReset hWave
    ' Остановка записи
    waveInStop hWave
   
    ' ОСвобождение заголовков буферов
    For i = 0 To UBound(Buffers)
        waveInUnprepareHeader hWave, Buffers(i).Header, Len(Buffers(i).Header)
    Next
   
    ' Закрытие устройства записи
    waveInClose hWave
End Sub
 
' Функция вызывается при очередном заполненном буфере
Public Function OnCapture(Hdr As WAVEHDR) As Boolean
    Dim i As Long
    ' Получаем индекс буфера
    i = modAudio.GetBufferIndex(Hdr.lpData)
    If i = -1 Then Exit Function
    ' Вызываем отрисовку
    modMain.Draw modAudio.Buffers(i).Data
    ' Отправка буфера устройству
    waveInAddBuffer hWave, Buffers(i).Header, Len(Buffers(i).Header)
End Function
 
' Функция возвращает индекс буфера по его указателю
Private Function GetBufferIndex(ByVal Ptr As Long) As Long
    Dim i As Long
    For i = 0 To UBound(Buffers)
        If Buffers(i).Header.lpData = Ptr Then GetBufferIndex = i: Exit Function
    Next
    GetBufferIndex = -1
End Function
 
' Процедура показывает сообщение об ошибке
Private Sub ShowMessage(ByVal Code As Long)
    Dim msg As String
    msg = Space(255)
    waveInGetErrorText Code, msg, Len(msg)
    MsgBox "Error capture." & vbNewLine & msg
End Sub

Viewing all 1304 articles
Browse latest View live




Latest Images