Public Function UserWndProcProto( _
                ByVal hwnd As Long, _
                ByVal uMsg As Long, _
                ByRef wParam As Long, _
                ByRef lParam As Long, _
                ByRef defCall As Boolean) As Long

' modFunctions.bas  - DLL for global subclassing
' © Anatoly Krivous (The trick), 2016
 
Option Explicit
 
Private Const TRICKWNDCLASS           As String = "TrickGlobalSubclass"         ' // Window class name
Private Const TRICKMUTEX              As String = "TrickGlobalSubclassMutex"    ' // Mutex name
Private Const TRICKMAP                As String = "TrickGlobalSubclassMap"      ' // Mapping name
 
' // This structure describes a message that is passed to subclasser application
Public Type MESSAGESTRUCT
    pWndProc        As Long     ' // Address of user window procedure
    callDef         As Boolean  ' // Determine whether call the default window proc or not
    lResult         As Long     ' // Returned value
    lParam          As Long     ' // Same as in WndProc
    wParam          As Long
    message         As Long
    hwnd            As Long
End Type
 
Private WM_SUBCLASS     As Long     ' // The message identifier for subclassing
                                    ' // Description:
                                    ' // wParam - a hWnd for subclassing
                                    ' // lParam - a hWnd that receives a WM_COPYDATA message
                                    ' // Return value - status
Private WM_UNSUBCLASS   As Long     ' // The message identifier for remove subclassing
Private WM_NEWMESSAGE   As Long     ' // New message available
Private hWndReceiver    As Long     ' // Handle of receiver window
Private isInitialized   As Boolean  ' // Determine whether dll is initialized or not
Private isClassReg      As Boolean  ' // Determine whether window class is registered or not
Private hMutex          As Long     ' // Handle of mutex object
Private pMapping        As Long     ' // Address of shared memory
Private hMap            As Long     ' // Handle of mapping object
Private pWndProcAddress As Long     ' // Address of WndProc procedure
 
' // This is EntryPoint procedure
Public Function DllEntry( _
                ByVal hInstDll As Long, _
                ByVal fdwReason As Long, _
                ByVal lpvReserved As Long) As Long
                
    If fdwReason = DLL_PROCESS_ATTACH Then
        
        ' // Register global communication message
        WM_SUBCLASS = RegisterWindowMessage("WM_SUBCLASS")
        WM_UNSUBCLASS = RegisterWindowMessage("WM_UNSUBCLASS")
        WM_NEWMESSAGE = RegisterWindowMessage("WM_NEWMESSAGE")
        
        ' // Create mutex
        hMutex = CreateMutex(ByVal 0&, 0, TRICKMUTEX)
        ' // Create mapping object
        hMap = CreateFileMapping(INVALID_HANDLE_VALUE, ByVal 0&, PAGE_READWRITE, 0, &H100, TRICKMAP)
        
        If hMap Then
            ' // Map shared memory
            pMapping = MapViewOfFile(hMap, FILE_MAP_WRITE, 0, 0, &H100)
            
        End If
        
        ' // Get address of WndProc
        pWndProcAddress = GetAddr(AddressOf WndProc)
        
        ' // Patch function
        PatchFunc AddressOf UserWndProcProto
 
    ElseIf fdwReason = DLL_PROCESS_DETACH Then
        
        ' // Release resources
        If hWndReceiver Then
        
            DestroyWindow hWndReceiver
            hWndReceiver = 0
            
        End If
        
        If isClassReg Then
        
            UnregisterClass TRICKWNDCLASS, App.hInstance
            isClassReg = False
            
        End If
        
        If hMutex Then
            
            CloseHandle hMutex
            hMutex = 0
            
        End If
        
        If pMapping Then
            
            UnmapViewOfFile ByVal pMapping
            CloseHandle hMap
            
            hMap = 0
            pMapping = 0
            
        End If
        
        isInitialized = False
        
    End If
    
    DllEntry = 1
    
End Function
 
' // You should call this procedure before any subclassing
Public Function Initialize() As Boolean
    Dim cls As WNDCLASSEX
    
    ' // Check DLL initialization
    If WM_SUBCLASS = 0 Or _
       WM_UNSUBCLASS = 0 Or _
       WM_NEWMESSAGE = 0 Or _
       hMutex = 0 Or _
       pMapping = 0 Then Exit Function
    
    cls.cbSize = Len(cls)
    cls.hInstance = App.hInstance
    cls.lpfnWndProc = GetAddr(AddressOf ReceiverProc)
    cls.lpszClassName = StrPtr(TRICKWNDCLASS)
    
    ' // Register class
    If RegisterClassEx(cls) = 0 Then Exit Function
    
    isClassReg = True
    
    ' // Create a receiver window
    hWndReceiver = CreateWindowEx(0, TRICKWNDCLASS, vbNullString, 0, 0, 0, 0, 0, HWND_MESSAGE, 0, App.hInstance, ByVal 0&)
    
    If hWndReceiver = 0 Then Exit Function
 
    ' // Set status
    isInitialized = True
    Initialize = True
    
End Function
 
' // This is main function to subclass window
Public Function SetSubclass( _
                ByVal hwnd As Long, _
                ByVal pWndProc As Long) As Boolean
    Dim pid     As Long
    Dim tid     As Long
    Dim hHook   As Long
    
    ' // Check initialization
    If Not isInitialized Then Exit Function
    
    ' // Get thread identifier
    tid = GetWindowThreadProcessId(hwnd, pid)
    
    If tid = App.ThreadID Then
        ' // Local
        If SetWindowSubclass(hwnd, pWndProcAddress, pWndProc, ByVal hWndReceiver) Then
            SetSubclass = True
        End If
    
    Else
    
        ' // Install hook
        hHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf CallWndProc, App.hInstance, tid)
       
        If hHook Then
            ' // Send message for subclassing
            ' // This message will be received in the CallWndProc procedure in the needed process
            SendMessage hwnd, WM_SUBCLASS, hWndReceiver, ByVal pWndProc
            ' // Success
            SetSubclass = True
    
            UnhookWindowsHookEx hHook
            
        End If
        
    End If
    
End Function
 
' // This is main function to unsubclass window
Public Function RemoveSubclass( _
                ByVal hwnd As Long, _
                ByVal pWndProc As Long) As Boolean
    
    If Not isInitialized Then Exit Function
    
    If SendMessage(hwnd, WM_UNSUBCLASS, pWndProc, ByVal 0&) Then
        RemoveSubclass = True
    End If
    
End Function
 
' // This is the callback hook procedure
Private Function CallWndProc( _
                 ByVal nCode As Long, _
                 ByVal wParam As Long, _
                 ByRef lParam As CWPSTRUCT) As Long
                
    If nCode = HC_ACTION Then
        
        ' // We can process a message
        Select Case lParam.message
        Case WM_SUBCLASS
            ' // Query for subclassing
            If SetWindowSubclass(lParam.hwnd, pWndProcAddress, lParam.lParam, ByVal lParam.wParam) Then
                ' // Increment library counter
                LoadLibrary App.EXEName
            End If
        End Select
        
    End If
    
    CallWndProc = CallNextHookEx(0, nCode, wParam, lParam)
    
End Function
 
' // This is new window subclass procedure
Private Function WndProc( _
                 ByVal hwnd As Long, _
                 ByVal Msg As Long, _
                 ByVal wParam As Long, _
                 ByVal lParam As Long, _
                 ByVal uIdSubclass As Long, _
                 ByVal dwRefData As Long) As Long
    Dim ret     As Long
    Dim data    As MESSAGESTRUCT
    
    Select Case Msg
    Case WM_SUBCLASS
        ' // Success
        ret = True
        
    Case WM_UNSUBCLASS
        ' // Unsubclass window
        RemoveWindowSubclass hwnd, pWndProcAddress, wParam
 
    Case Else
        ' // Try to capture mutex for exclusive access
        If WaitForSingleObject(hMutex, INFINITE) = WAIT_OBJECT_0 Then
            
            ' // Fill message struct
            data.pWndProc = uIdSubclass
            data.callDef = True
            data.hwnd = hwnd
            data.message = Msg
            data.lParam = lParam
            data.wParam = wParam
            data.lResult = 0
            
            ' // Copy to shared memory
            memcpy ByVal pMapping, data, LenB(data)
            
            ' // Send message to the caller application window
            If SendMessage(dwRefData, WM_NEWMESSAGE, hwnd, ByVal App.ThreadID) Then
            
                ' // Check if need to call the default procedure
                memcpy data, ByVal pMapping, LenB(data)
                
                If data.callDef Then
                    ret = DefSubclassProc(data.hwnd, data.message, data.wParam, data.lParam)
                Else
                    ret = data.lResult
                End If
                
            Else
                ret = DefSubclassProc(hwnd, Msg, wParam, lParam)
            End If
            
            ' // Release mutex
            ReleaseMutex hMutex
            
        Else
            
            ret = DefSubclassProc(hwnd, Msg, wParam, lParam)
            
        End If
        
    End Select
    
    ' // Return value
    WndProc = ret
    
End Function
 
' // This is TrickGlobalSubclass window procedure
Private Function ReceiverProc( _
                 ByVal hwnd As Long, _
                 ByVal uMsg As Long, _
                 ByVal wParam As Long, _
                 ByVal lParam As Long) As Long
    Dim data    As MESSAGESTRUCT
    
    ' // Check window message
    If uMsg = WM_NEWMESSAGE Then
        ' // Mutex already is captured therefore an access to shared data is an atomic
        ' // Get message data form shared memory
        memcpy data, ByVal pMapping, LenB(data)
        ' // Call user window proc by pointer
        data.lResult = UserWndProcProto(data.pWndProc, data.hwnd, data.message, data.wParam, data.lParam, data.callDef)
        ' // Copy parameters
        memcpy ByVal pMapping, data, LenB(data)
        ' // Success
        ReceiverProc = True
    Else
        ReceiverProc = DefWindowProc(hwnd, uMsg, wParam, lParam)
    End If
    
End Function
 
Private Function UserWndProcProto( _
                 ByVal pAddress As Long, _
                 ByVal hwnd As Long, _
                 ByVal uMsg As Long, _
                 ByRef wParam As Long, _
                 ByRef lParam As Long, _
                 ByRef defCall As Boolean) As Long
End Function
 
Private Function GetAddr( _
                 ByVal Addr As Long) As Long
    GetAddr = Addr
End Function

Option Explicit
 
Dim WithEvents pb As PictureBox
Dim w&, h&, ww&, hh&, sw&, sh&
 
Private Sub Form_Load()
    ChDir App.Path
    Set pb = Controls.Add("vb.PictureBox", "pb"): With pb
        .AutoSize = 1
        .AutoRedraw = 1
        .BorderStyle = 0
        .Picture = LoadPicture("0.jpg")
        .Visible = 1
    End With
    Def sw, Width - ScaleWidth, sh, Height - ScaleHeight
End Sub
 
Private Sub Form_Resize()
    Def ww, -(pb.Width - Width + sw), hh, -(pb.Height - Height + sh): pb.Move 0, 0
End Sub
 
Private Sub pb_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Static l&, ll&, t&, tt&
    If Button Then
        Def ll, pb.Left + (X - l), tt, pb.Top + (Y - t)
        If ll <= 0 And ll >= ww Then pb.Left = ll
        If tt <= 0 And tt >= hh Then pb.Top = tt
    Else: Def l, X, t, Y
    End If
End Sub
Sub Def(ParamArray w()): Dim i&: For i = 0 To UBound(w) Step 2: w(i) = w(i + 1): Next: End Sub

Option Explicit
 
Private Const SWP_NOMOVE As Long = &H2
Private Const SWP_NOSIZE = &H1
 
Private Type RECT
    left As Long
    top As Long
    right As Long
    bottom As Long
End Type
Private Type COMBOBOXINFO
    cbSize As Long
    rcItem As RECT
    rcButton As RECT
    stateButton As Long
    hWndCombo As Long
    hwndEdit As Long
    hWndList As Long
End Type
 
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetComboBoxInfo Lib "user32.dll" (ByVal hWndCombo As Long, ByRef CBInfo As COMBOBOXINFO) As Long
Private Declare Function SetParent Lib "user32.dll" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function SetWindowPos Lib "user32.dll" (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 Declare Function IsWindowVisible Lib "user32.dll" (ByVal hwnd As Long) As Long
 
Dim WithEvents cbx As ComboBox, WithEvents tmr As Timer
Dim cbi As COMBOBOXINFO, rPic As RECT, www&
 
Private Sub Form_Activate()
    Set cbx = Controls.Add("vb.combobox", "cbx"): With cbx
        .Move 300, 300, 3000
        .Text = "Картинка в выпадающем списке"
        .Visible = 1
    End With
    Set tmr = Controls.Add("vb.timer", "tmr"): tmr.Interval = 100
    cbi.cbSize = Len(cbi)
    Call GetComboBoxInfo(cbx.hwnd, cbi)
    SetParent Picture1.hwnd, cbi.hWndList
    SetWindowPos Picture1.hwnd, 0, 0, 0, 0, 0, SWP_NOSIZE
End Sub
 
 
Private Sub tmr_Timer()
    Static b1 As Boolean, b2 As Boolean
    b1 = IsWindowVisible(cbi.hWndList)
    If b1 And b2 = False Then
        'Размер списка изменяется под картинку, только когда расскрывается список
        b2 = True: SetWindowPos cbi.hWndList, 0, 0, 0, Picture1.Width \ 15, Picture1.Height \ 15, SWP_NOMOVE
    ElseIf b1 = False And b2 Then
        b2 = False
    End If
End Sub

Option Explicit
 
Private Enum TErrorCorretion
    QualityLow
    QualityMedium
    QualityStandard
    QualityHigh
End Enum
 
Private Declare Sub GenerateBMP _
                Lib "D:\quricol32.dll" _
                Alias "GenerateBMPW" ( _
                ByVal FileName As Long, _
                ByVal Text As Long, _
                ByVal Margin As Long, _
                ByVal Size As Long, _
                ByVal Level As TErrorCorretion)
                
Private Sub Command1_Click()
On Error Resume Next
    GenerateBMP StrPtr("D:\Example.bmp"), StrPtr("Ваш текст!!!"), 3, 5, QualityLow
End Sub