dcsimg
Results 1 to 20 of 20

Thread: [VB6] - Class for subclassing windows and classes.

  1. #1

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,353

    [VB6] - Class for subclassing windows and classes.



    Hello everyone! Developed a class with which you can work with subclassing. The class has an event WndProc, which is caused when receiving the message window. You can also put on a class subclassing windows. There are methods to pause subclassing and its removal, as well as information on subclassing. Work very convenient, because stop button can stop the project without any consequences. Run better through "Start with full compile", because This will prevent crashes, a failed compilation. I imagine even brought a separate button next to the regular compilation and use it.

    A little bit about working with the class. To install subclassing the window method is called Hook, with a handle of the window. If the method returns True, then subclassing installed. Event processing "WndProc", you can change the behavior of the window. In argument Ret can transfer the return value if you want to call the procedure by default, then you need to pass in the argument DefCall True.
    To install windows subclassing a group (class), you need to call a method HookClass, passing a handle window whose class you need to intercept. On success, the method returns True. Subclassing will operate from next window created in this class, ie, on the parameter passed subclassing will not work. Also by default, this type of subclassing suspended. I did it because of the fact that if you do not process messages create windows properly, then the project will not start with error Out of memory.
    • To remove the need to call a method of subclassing Unhook, Returns True on success.
    • To pause subclassing provides methods and PauseSubclass ResumeSubclass, Returns True on success.
    • HWnd property returns the handle of the window, which is set subclassing (for the installation of windows subclassing a class, returns the passed parameter).
    • IsSubclassed property is designed to determine if it is installed or not subclassing.
    • IsClass property returns True, if mounted on a class subclassing windows.
    • IsPaused property returns True, if subclassing suspended.

    Version 1.1:
    • added method CallDef, allows you to call the previous window procedure for a given message.
    • added property Previous, which returns the address of the previous window procedure.
    • added property Current, which returns the address of the current window procedure.

    Version 2.0:
    • remove the methods that work with the window classes.
    • class works more stable because it uses the other subclassing method (SetWindowSubclass).

    Version 2.1:
    • more stable works. Don't worry about the errors, stop-button, editing code during execution.

    Version 2.2:
    • more stable works. Fix previous bugs.

    For the test I did a small project, which uses subclassing opportunities. Set the timer (SetTimer), replacement for the standard context menu textbox restriction on resizing forms, capturing the "arrival" / "left" mouse over / out of control.
    Last edited by The trick; Jan 12th, 2016 at 10:39 AM.

  2. #2

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,353

    Re: [VB6] - Class for subclassing windows and classes.

    The source code module clsTrickSubclass.cls:
    Code:
    Option Explicit
     
    ' Класс clsTrickSubclass.cls - для сабклассинга в VB6
    ' © Кривоус Анатолий Анатольевич (The trick), 2014
    ' Версия 1.1
     
    Private Type PROCESS_HEAP_ENTRY
        lpData              As Long
        cbData              As Long
        cbOverhead          As Byte
        iRegionIndex        As Byte
        wFlags              As Integer
        dwCommittedSize     As Long
        dwUnCommittedSize   As Long
        lpFirstBlock        As Long
        lpLastBlock         As Long
    End Type
     
    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 Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As Long) As Long
    Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
    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 HeapWalk Lib "kernel32" (ByVal hHeap As Long, ByRef lpEntry As PROCESS_HEAP_ENTRY) As Long
    Private Declare Function HeapLock Lib "kernel32" (ByVal hHeap As Long) As Long
    Private Declare Function HeapUnlock Lib "kernel32" (ByVal hHeap As Long) As Long
    Private Declare Function SetEnvironmentVariable Lib "kernel32" Alias "SetEnvironmentVariableW" (ByVal lpName As Long, ByVal lpValue As Long) As Long
    Private Declare Function GetEnvironmentVariable Lib "kernel32" Alias "GetEnvironmentVariableW" (ByVal lpName As Long, ByVal lpBuffer As Long, ByVal nSize As Long) As Long
    Private Declare Function GetMem4 Lib "msvbvm60" (pSrc As Any, pDst As Any) 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 GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
     
    Private Const WM_CREATE                     As Long = &H1
    Private Const WM_DESTROY                    As Long = &H2
    Private Const GCL_WNDPROC                   As Long = (-24)
    Private Const GWL_WNDPROC                   As Long = (-4)
    Private Const HEAP_CREATE_ENABLE_EXECUTE    As Long = &H40000
    Private Const HEAP_NO_SERIALIZE             As Long = &H1
    Private Const HEAP_ZERO_MEMORY              As Long = &H8
    Private Const PROCESS_HEAP_ENTRY_BUSY       As Long = &H4
    Private Const WNDPROCINDEX                  As Long = 12
    Private Const EnvName                       As String = "TrickSubclass"
     
    ' Событие, возникающее при вызове процедуры окна. Ret - возвращаемое значение, DefCall - вызвать предыдущую процедуру
    Public Event WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, Ret As Long, DefCall As Boolean)
     
    Private mIsSubclassed   As Boolean
    Private mhWnd           As Long
    Private mIsClass        As Boolean
    Private mIsPaused       As Boolean
     
    Dim lpPrev      As Long
    Dim hHeap       As Long
    Dim lpAsm       As Long
    Dim ClsCount    As Long
     
    ' Возвращает дескриптор окна
    Public Property Get hwnd() As Long
        hwnd = mhWnd
    End Property
    ' Возвращает адрес предыдущей процедуры
    Public Property Get Previous() As Long
        If mIsSubclassed Then Previous = lpPrev
    End Property
    ' Возвращает адрес текущей процедуры
    Public Property Get Current() As Long
        If mIsSubclassed Then Current = lpAsm
    End Property
    ' Если был сабклассинг, то True
    Public Property Get IsSubclassed() As Boolean
        IsSubclassed = mIsSubclassed
    End Property
    ' Приостановить сабклассинг
    Public Function PauseSubclass() As Boolean
        If mIsSubclassed And Not mIsPaused Then mIsPaused = True: PauseSubclass = True
    End Function
    ' Возобновить сабклассинг
    Public Function ResumeSubclass() As Boolean
        If mIsSubclassed And mIsPaused Then mIsPaused = False: ResumeSubclass = True
    End Function
    ' Если сабклассинг класса, то  True
    Public Property Get IsClass() As Boolean
        IsClass = mIsClass
    End Property
    ' Если на паузе то True
    Public Property Get IsPaused() As Boolean
        IsPaused = mIsPaused
    End Property
    ' Установить хук на класс (если хук стоит, то он будет снят)
    ' Действует на все последующие экземпляры окон
    Public Function HookClass(ByVal hwnd As Long) As Boolean
        If mIsSubclassed Then
            If Not UnHook Then Exit Function
        End If
        lpPrev = GetClassLong(hwnd, GCL_WNDPROC)
        mIsClass = True
        If CreateAsm Then
            If SetClassLong(hwnd, GCL_WNDPROC, lpAsm) Then
                mhWnd = hwnd
                mIsSubclassed = True
                HookClass = True
                mIsPaused = True
            Else: mIsClass = False
            End If
        Else: mIsClass = False
        End If
    End Function
    ' Установить хук на окно (если хук стоит, то он будет снят)
    Public Function Hook(ByVal hwnd As Long) As Boolean
        If mIsSubclassed Then
            If Not UnHook Then Exit Function
        End If
        lpPrev = GetWindowLong(hwnd, GWL_WNDPROC)
        mIsClass = False
        If CreateAsm Then
            If SetWindowLong(hwnd, GWL_WNDPROC, lpAsm) Then
                mhWnd = hwnd
                mIsSubclassed = True
                Hook = True
            End If
        End If
    End Function
    ' Снять хук
    Public Function UnHook() As Boolean
        If Not mIsSubclassed Then Exit Function
        If mIsClass Then
            UnHook = SetClassLong(mhWnd, GCL_WNDPROC, lpPrev)
        Else: UnHook = SetWindowLong(mhWnd, GWL_WNDPROC, lpPrev)
        End If
        If UnHook Then mhWnd = 0: mIsSubclassed = False
    End Function
    ' Вызвать процедуру по умолчанию для окна
    Public Function CallDef(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, ByRef Status As Boolean) As Long
        If Not mIsSubclassed Then Exit Function
        CallDef = CallWindowProc(lpPrev, hwnd, Msg, wParam, lParam)
        Status = True
    End Function
    ' --------------------------------------------------------------------------------------------------------------------------------------
    Private Function mWndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
        If mIsPaused Then
            mWndProc = CallWindowProc(lpPrev, hwnd, Msg, wParam, lParam)
        Else
            Dim DefCall As Boolean
            RaiseEvent WndProc(hwnd, Msg, wParam, lParam, mWndProc, DefCall)
            If DefCall Then mWndProc = CallWindowProc(lpPrev, hwnd, Msg, wParam, lParam)
        End If
        If mIsClass And mWndProc = 0 Then
            Select Case Msg
            Case WM_CREATE: ClsCount = ClsCount + 1
            Case WM_DESTROY
                ClsCount = ClsCount - 1
                If ClsCount = 0 Then mhWnd = hwnd: UnHook
            End Select
        End If
    End Function
    Private Sub Class_Terminate()
        If hHeap = 0 Then Exit Sub
        UnHook
        If CountHooks = 1 Then
            HeapDestroy hHeap
            hHeap = 0
            SaveCurHeap
        Else
            HeapFree hHeap, HEAP_NO_SERIALIZE, ByVal lpAsm
        End If
    End Sub
    Private Function CreateAsm() As Boolean
        Dim inIDE   As Boolean
        Dim AsmSize As Long
        Dim ptr     As Long
        Dim isFirst As Boolean
     
        Debug.Assert MakeTrue(inIDE)
        
        If lpAsm = 0 Then
            If inIDE Then AsmSize = &H51 Else AsmSize = &H1D
            hHeap = GetPrevHeap()
            
            If hHeap Then
                If inIDE Then
                    Dim flag    As Long
                    ptr = GetFlagPointer()
                    GetMem4 ByVal ptr, flag
                    If flag Then
                        HeapDestroy hHeap
                        isFirst = True
                    End If
                End If
            Else: isFirst = True
            End If
            
            If isFirst Then
                hHeap = HeapCreate(HEAP_CREATE_ENABLE_EXECUTE Or HEAP_NO_SERIALIZE, 0, 0)
                If hHeap = 0 Then Err.Raise 7: Exit Function
                If Not SaveCurHeap() Then HeapDestroy hHeap: hHeap = 0: Err.Raise 7: Exit Function
                AsmSize = AsmSize + &H4
            End If
            
            lpAsm = HeapAlloc(hHeap, HEAP_NO_SERIALIZE Or HEAP_ZERO_MEMORY, AsmSize)
            
            If lpAsm = 0 Then
                If isFirst Then HeapDestroy hHeap
                hHeap = 0
                Err.Raise 7
                Exit Function
            End If
            
            Dim prv As Long
            Dim i   As Long
            
            If inIDE Then
                If isFirst Then
                    GetMem4 0&, ByVal lpAsm
                    lpAsm = lpAsm + 4
                End If
            End If
            
        End If
        ptr = lpAsm
        If inIDE Then
            CreateIDEStub (ptr): ptr = ptr + &H34
        End If
        CreateStackConv ptr
        CreateAsm = True
        
    End Function
    Private Function GetFlagPointer() As Long
        Dim he  As PROCESS_HEAP_ENTRY
        HeapLock hHeap
        Do While HeapWalk(hHeap, he)
            If he.wFlags And PROCESS_HEAP_ENTRY_BUSY Then GetFlagPointer = he.lpData: Exit Function
        Loop
        HeapUnlock hHeap
    End Function
    Private Function CountHooks() As Long
        Dim he  As PROCESS_HEAP_ENTRY
        HeapLock hHeap
        Do While HeapWalk(hHeap, he)
            If he.wFlags And PROCESS_HEAP_ENTRY_BUSY Then CountHooks = CountHooks + 1
        Loop
        HeapUnlock hHeap
    End Function
    Private Function SaveCurHeap() As Boolean
        Dim i   As Long
        Dim out As String
        out = Hex(hHeap)
        For i = Len(out) + 1 To 8: out = "0" & out: Next
        SaveCurHeap = SetEnvironmentVariable(StrPtr(EnvName), StrPtr(out))
    End Function
    Private Function GetPrevHeap() As Long
        Dim out         As String
        out = Space(&H8)
        If GetEnvironmentVariable(StrPtr(EnvName), StrPtr(out), LenB(out)) Then GetPrevHeap = Val("&H" & out)
    End Function
    Private Function CreateStackConv(ByVal ptr As Long) As Boolean
        Dim lpMeth      As Long
        Dim vTable      As Long
        
        GetMem4 ByVal ObjPtr(Me), vTable
        GetMem4 ByVal vTable + WNDPROCINDEX * 4 + &H1C, lpMeth
        
        GetMem4 &H5450C031, ByVal ptr + &H0:    GetMem4 &H488DE409, ByVal ptr + &H4:    GetMem4 &H2474FF04, ByVal ptr + &H8
        GetMem4 &H68FAE018, ByVal ptr + &HC:    GetMem4 &H0, ByVal ptr + &H10:          GetMem4 &HE8, ByVal ptr + &H14
        GetMem4 &H10C25800, ByVal ptr + &H18:   GetMem4 &H9000, ByVal ptr + &H1C
        
        GetMem4 ObjPtr(Me), ByVal ptr + &H10                    ' Push Me
        GetMem4 lpMeth - (ptr + &H14) - 5, ByVal ptr + &H14 + 1 ' Call WndProc
        
    End Function
     
    Private Function CreateIDEStub(ByVal ptr As Long) As Boolean
        Dim hInstVB6    As Long
        Dim lpEbMode    As Long
        Dim hInstUser32 As Long
        Dim lpCallProc  As Long
        Dim lpSetLong   As Long
        Dim dwIndex     As Long
        
        hInstVB6 = GetModuleHandle(StrPtr("vba6"))
        If hInstVB6 = 0 Then Exit Function
        hInstUser32 = GetModuleHandle(StrPtr("user32"))
        If hInstUser32 = 0 Then Exit Function
        
        lpEbMode = GetProcAddress(hInstVB6, "EbMode")
        If lpEbMode = 0 Then Exit Function
        lpCallProc = GetProcAddress(hInstUser32, "CallWindowProcW")
        If lpCallProc = 0 Then Exit Function
        If mIsClass Then
            lpSetLong = GetProcAddress(hInstUser32, "SetClassLongA")
            dwIndex = GCL_WNDPROC
        Else
            lpSetLong = GetProcAddress(hInstUser32, "SetWindowLongA")
            dwIndex = GWL_WNDPROC
        End If
        If lpSetLong = 0 Then Exit Function
        
        GetMem4 &HFFFFFBE8, ByVal ptr + &H0:    GetMem4 &H74C084FF, ByVal ptr + &H4:    GetMem4 &H74013C10, ByVal ptr + &H8
        GetMem4 &H685827, ByVal ptr + &HC:      GetMem4 &H50000000, ByVal ptr + &H10:   GetMem4 &HFFFFE7E9, ByVal ptr + &H14
        GetMem4 &HDFFFF, ByVal ptr + &H18:      GetMem4 &H68000000, ByVal ptr + &H1C:   GetMem4 lpPrev, ByVal ptr + &H20
        GetMem4 &H68, ByVal ptr + &H24:         GetMem4 &HE474FF98, ByVal ptr + &H28:   GetMem4 &HFFCEE80C, ByVal ptr + &H2C
        GetMem4 &HD9EBFFFF, ByVal ptr + &H30
        
        GetMem4 lpEbMode - ptr - 5, ByVal ptr + 1 + 0               ' Call EbMode
        GetMem4 lpPrev, ByVal ptr + &HF                             ' Push PrevProc
        GetMem4 lpCallProc - (ptr + &H14) - 5, ByVal ptr + 1 + &H14 ' Jmp CallWindowProcA
        GetMem4 dwIndex, ByVal ptr + &H25                           ' Push nIndex
        GetMem4 lpSetLong - (ptr + &H2D) - 5, ByVal ptr + 1 + &H2D  ' Call SetWindowLong/SetClassLong
        GetMem4 ptr - 4, ByVal ptr + &H1B                           ' dec dword ptr [Flag]
        
        CreateIDEStub = True
    End Function
    Private Function MakeTrue(Value As Boolean) As Boolean: Value = True: MakeTrue = True: End Function

  3. #3

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,353

    Re: [VB6] - Class for subclassing windows and classes.

    The source code of the test:
    Code:
    Option Explicit
     
    ' Тест модуля clsTrickSubclass.cls
    ' В данном модуле с помощью сабклассинга сделаем:
    ' - Ограничение на минимальный и максимальный размер формы
    ' - Вместо стандартного контекстного меню текстбокса вставим свое
    ' - Будем отлавливать сообщение покидания мышью контрола (MouseLeave) и захода (MouseEnter)
    ' - Поставим таймер на окно
     
    Private Type POINTAPI
        x As Long
        y As Long
    End Type
    Private Type MINMAXINFO
        ptReserved          As POINTAPI
        ptMaxSize           As POINTAPI
        ptMaxPosition       As POINTAPI
        ptMinTrackSize      As POINTAPI
        ptMaxTrackSize      As POINTAPI
    End Type
    Private Type tagTRACKMOUSEEVENT
        cbSize As Long
        dwFlags As Long
        hwndTrack As Long
        dwHoverTime As Long
    End Type
     
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function TrackMouseEvent Lib "user32" (ByRef lpEventTrack As tagTRACKMOUSEEVENT) As Long
    Private Declare Function vbaObjSetAddref Lib "MSVBVM60.DLL" Alias "__vbaObjSetAddref" (dstObject As IUnknown, ByVal srcObjPtr 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 SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
     
    Private Const GWL_USERDATA      As Long = &HFFFFFFEB
    Private Const WM_GETMINMAXINFO  As Long = &H24
    Private Const WM_CONTEXTMENU    As Long = &H7B
    Private Const WM_NCCALCSIZE     As Long = &H83
    Private Const WM_MOUSEMOVE      As Long = &H200
    Private Const WM_MOUSELEAVE     As Long = &H2A3
    Private Const WM_TIMER          As Long = &H113
    Private Const TME_QUERY         As Long = &H40000000
    Private Const TME_LEAVE         As Long = &H2
     
    Dim WithEvents HookForm     As clsTrickSubclass         ' Для сабклассинга формы
    Dim WithEvents HookText     As clsTrickSubclass         ' Для сабклассинга текстбокса
    Dim WithEvents HookClass    As clsTrickSubclass         ' Для сабклассинга всех кнопок
     
    Private Sub cmdButton_Click(Index As Integer)
        If Index = 0 Then
            If HookClass.IsPaused Then
                cmdButton(0).Caption = "Pause"
                HookClass.ResumeSubclass
            Else
                cmdButton(0).Caption = "Run"
                HookClass.PauseSubclass
            End If
        End If
    End Sub
     
    Private Sub Form_Load()
        Dim i As Long
        
        Set HookForm = New clsTrickSubclass
        Set HookText = New clsTrickSubclass
        Set HookClass = New clsTrickSubclass
        HookForm.Hook Me.hwnd                   ' Сабклассируем форму
        HookText.Hook txtTest.hwnd              ' Сабклассируем текстбокс
        HookClass.HookClass cmdButton(0).hwnd   ' Сабклассируем все последующие кнопки
        HookClass.ResumeSubclass                ' Т.к. по умолчанию глобальный сабклассинг приостановлен
        
        ' Все эти кнопки и вообще любые кнопки (CommandButton), которые мы будем добавлять будут отрабатывать в процедуре HookClass_WndProc
        For i = 1 To 5
            Load cmdButton(i)
            SetWindowLong cmdButton(i).hwnd, GWL_USERDATA, ObjPtr(cmdButton(i))
            cmdButton(i).Caption = Array("Global", "subclass", "by", "The trick", "2014")(i - 1)
        Next
        
        SetTimer hwnd, 1, 100, 0
    End Sub
     
    Private Sub Form_Resize()
        Dim cmd As CommandButton
        Dim w   As Long
        Dim h   As Long
        Dim y   As Long
        Dim x   As Long
        
        If WindowState = vbMinimized Then Exit Sub
        
        txtTest.Move 5, 5, ScaleWidth - 10, 200
        
        y = txtTest.Top + txtTest.Height + 5: x = 5
        w = (ScaleWidth - 10) / cmdButton.Count * 2: h = (ScaleHeight - y - 5) / 2
        
        For Each cmd In cmdButton
            cmd.Visible = True: cmd.Move x, y, w - 4, h - 4: x = x + w
            If x > ScaleWidth - w Then x = 5: y = y + h
        Next
    End Sub
     
    ' Процедура обработки сообщений кнопок
    Private Sub HookClass_WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, Ret As Long, DefCall As Boolean)
        Dim cmd As CommandButton
        Select Case Msg
        Case WM_MOUSELEAVE                  ' Мышь вышла за пределы контрола
            vbaObjSetAddref cmd, GetWindowLong(hwnd, GWL_USERDATA)
            cmd.FontUnderline = False
            DefCall = True
        Case WM_MOUSEMOVE
            Dim tme As tagTRACKMOUSEEVENT
            vbaObjSetAddref cmd, GetWindowLong(hwnd, GWL_USERDATA)
            tme.cbSize = Len(tme)
            tme.dwFlags = TME_QUERY
            TrackMouseEvent tme
            If tme.hwndTrack <> hwnd Then
                tme.dwFlags = TME_LEAVE     ' Мышь вошла в контрол
                tme.hwndTrack = hwnd
                TrackMouseEvent tme
                cmd.FontUnderline = True
            End If
            DefCall = True
        Case Else: DefCall = True
        End Select
    End Sub
    ' Процедура обработки сообщений формы
    Private Sub HookForm_WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, Ret As Long, DefCall As Boolean)
        Select Case Msg
        Case WM_TIMER
            If wParam = 1 Then
                Caption = Right(Caption, Len(Caption) - 1) & Left(Caption, 1)
                Exit Sub
            End If
            DefCall = True
        Case WM_GETMINMAXINFO               ' Обрабатываем минимальный и максимальный размер формы
            Dim MinMax As MINMAXINFO
            CopyMemory MinMax, ByVal lParam, Len(MinMax)
            MinMax.ptMaxTrackSize.x = 500   ' Максимальный размер 500х500
            MinMax.ptMaxTrackSize.y = 500
            MinMax.ptMinTrackSize.x = 350   ' Минимальный размер 350х350
            MinMax.ptMinTrackSize.y = 350
            CopyMemory ByVal lParam, MinMax, Len(MinMax)
        Case Else: DefCall = True
        End Select
    End Sub
    ' Процедура обработки сообщений текстбокса
    Private Sub HookText_WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, Ret As Long, DefCall As Boolean)
        Select Case Msg
        Case WM_CONTEXTMENU                 ' Вставляем свое меню
            PopupMenu mnuPopup
        Case Else: DefCall = True
        End Select
    End Sub
    Good luck!

    TrickSubClass.zip

  4. #4

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,353

    Re: [VB6] - Class for subclassing windows and classes.

    VERSION 2.0

    Used SetWindowSubclass function.

    Code:
    Option Explicit
    
    ' clsTrickSubclass2.cls - class for window subclassing
    ' © Krivous Anatolii Anatolevich (The trick), 2015
    ' Version 2.0
    
    Private Type PROCESS_HEAP_ENTRY
        lpData              As Long
        cbData              As Long
        cbOverhead          As Byte
        iRegionIndex        As Byte
        wFlags              As Integer
        dwCommittedSize     As Long
        dwUnCommittedSize   As Long
        lpFirstBlock        As Long
        lpLastBlock         As Long
    End Type
    
    Private Declare Function SetWindowSubclass Lib "Comctl32" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, dwRefData As Any) As Long
    Private Declare Function RemoveWindowSubclass Lib "Comctl32" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
    Private Declare Function DefSubclassProc Lib "Comctl32" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As Long) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As Long) As Long
    Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
    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 HeapWalk Lib "kernel32" (ByVal hHeap As Long, ByRef lpEntry As PROCESS_HEAP_ENTRY) As Long
    Private Declare Function HeapLock Lib "kernel32" (ByVal hHeap As Long) As Long
    Private Declare Function HeapUnlock Lib "kernel32" (ByVal hHeap As Long) As Long
    Private Declare Function SetEnvironmentVariable Lib "kernel32" Alias "SetEnvironmentVariableW" (ByVal lpName As Long, ByVal lpValue As Long) As Long
    Private Declare Function GetEnvironmentVariable Lib "kernel32" Alias "GetEnvironmentVariableW" (ByVal lpName As Long, ByVal lpBuffer As Long, ByVal nSize As Long) As Long
    Private Declare Function GetMem4 Lib "msvbvm60" (pSrc As Any, pDst As Any) As Long
    
    Private Const WM_CREATE                     As Long = &H1
    Private Const WM_DESTROY                    As Long = &H2
    Private Const GCL_WNDPROC                   As Long = (-24)
    Private Const GWL_WNDPROC                   As Long = (-4)
    Private Const HEAP_CREATE_ENABLE_EXECUTE    As Long = &H40000
    Private Const HEAP_NO_SERIALIZE             As Long = &H1
    Private Const HEAP_ZERO_MEMORY              As Long = &H8
    Private Const PROCESS_HEAP_ENTRY_BUSY       As Long = &H4
    Private Const WNDPROCINDEX                  As Long = 8
    Private Const EnvName                       As String = "TrickSubclass"
    
    Public Event WndProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, Ret As Long, DefCall As Boolean)
    
    Private mIsSubclassed   As Boolean
    Private mhWnd           As Long
    Private mIsPaused       As Boolean
    
    Dim hHeap   As Long
    Dim lpAsm   As Long
    
    ' Return a window handle
    Public Property Get hWnd() As Long
        hWnd = mhWnd
    End Property
    ' Subclassing state (True - subclassing on)
    Public Property Get IsSubclassed() As Boolean
        IsSubclassed = mIsSubclassed
    End Property
    ' Pause subclassing
    Public Function PauseSubclass() As Boolean
        If mIsSubclassed And Not mIsPaused Then mIsPaused = True: PauseSubclass = True
    End Function
    ' Resume
    Public Function ResumeSubclass() As Boolean
        If mIsSubclassed And mIsPaused Then mIsPaused = False: ResumeSubclass = True
    End Function
    ' If pause then return True
    Public Property Get IsPaused() As Boolean
        IsPaused = mIsPaused
    End Property
    ' Set subclassing to window (if subclassing already enabled then remove it)
    Public Function Hook(ByVal hWnd As Long) As Boolean
    
        If mIsSubclassed Then
            If Not UnHook Then Exit Function
        End If
        
        If CreateAsm Then
        
            mIsSubclassed = SetWindowSubclass(hWnd, lpAsm, ObjPtr(Me), 0)
            
            If mIsSubclassed Then
                Hook = True
                mhWnd = hWnd
            End If
            
        End If
        
    End Function
    ' Remove subclassing
    Public Function UnHook() As Boolean
        If Not mIsSubclassed Then Exit Function
        UnHook = RemoveWindowSubclass(mhWnd, lpAsm, ObjPtr(Me))
        If UnHook Then mhWnd = 0: mIsSubclassed = False
    End Function
    ' Call default procedure
    Public Function CallDef(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, ByRef Status As Boolean) As Long
        If Not mIsSubclassed Then Exit Function
        CallDef = DefSubclassProc(hWnd, Msg, wParam, lParam)
        Status = True
    End Function
    
    ' --------------------------------------------------------------------------------------------------------------------------------------
    Private Function SUBCLASSPROC(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
        
        If mIsPaused Then
            SUBCLASSPROC = DefSubclassProc(hWnd, Msg, wParam, lParam)
        Else
            Dim DefCall As Boolean
            RaiseEvent WndProc(hWnd, Msg, wParam, lParam, SUBCLASSPROC, DefCall)
            If DefCall Then SUBCLASSPROC = DefSubclassProc(hWnd, Msg, wParam, lParam)
        End If
        
    End Function
    Private Sub Class_Terminate()
        If hHeap = 0 Then Exit Sub
        UnHook
        If CountHooks = 1 Then
            HeapDestroy hHeap
            hHeap = 0
            SaveCurHeap
        Else
            HeapFree hHeap, HEAP_NO_SERIALIZE, ByVal lpAsm
        End If
    End Sub
    Private Function CreateAsm() As Boolean
        Dim inIDE   As Boolean
        Dim AsmSize As Long
        Dim ptr     As Long
        Dim isFirst As Boolean
    
        Debug.Assert MakeTrue(inIDE)
        
        If lpAsm = 0 Then
            If inIDE Then AsmSize = &H5E Else AsmSize = &H1D
            hHeap = GetPrevHeap()
            
            If hHeap Then
                If inIDE Then
                    Dim flag    As Long
                    ptr = GetFlagPointer()
                    GetMem4 ByVal ptr, flag
                    If flag Then
                        HeapDestroy hHeap
                        isFirst = True
                    End If
                End If
            Else: isFirst = True
            End If
            
            If isFirst Then
                hHeap = HeapCreate(HEAP_CREATE_ENABLE_EXECUTE Or HEAP_NO_SERIALIZE, 0, 0)
                If hHeap = 0 Then Err.Raise 7: Exit Function
                If Not SaveCurHeap() Then HeapDestroy hHeap: hHeap = 0: Err.Raise 7: Exit Function
                AsmSize = AsmSize + &H4
            End If
            
            lpAsm = HeapAlloc(hHeap, HEAP_NO_SERIALIZE Or HEAP_ZERO_MEMORY, AsmSize)
            
            If lpAsm = 0 Then
                If isFirst Then HeapDestroy hHeap
                hHeap = 0
                Err.Raise 7
                Exit Function
            End If
            
            Dim prv As Long
            Dim i   As Long
            
            If inIDE Then
                If isFirst Then
                    GetMem4 0&, ByVal lpAsm
                    lpAsm = lpAsm + 4
                End If
            End If
            
        End If
        
        ptr = lpAsm
        
        If inIDE Then
            CreateIDEStub (ptr): ptr = ptr + &H40
        End If
        
        CreateStackConv ptr
        CreateAsm = True
        
    End Function
    Private Function GetFlagPointer() As Long
        Dim he  As PROCESS_HEAP_ENTRY
        HeapLock hHeap
        Do While HeapWalk(hHeap, he)
            If he.wFlags And PROCESS_HEAP_ENTRY_BUSY Then GetFlagPointer = he.lpData: Exit Function
        Loop
        HeapUnlock hHeap
    End Function
    Private Function CountHooks() As Long
        Dim he  As PROCESS_HEAP_ENTRY
        HeapLock hHeap
        Do While HeapWalk(hHeap, he)
            If he.wFlags And PROCESS_HEAP_ENTRY_BUSY Then CountHooks = CountHooks + 1
        Loop
        HeapUnlock hHeap
    End Function
    Private Function SaveCurHeap() As Boolean
        Dim i   As Long
        Dim out As String
        out = Hex(hHeap)
        For i = Len(out) + 1 To 8: out = "0" & out: Next
        SaveCurHeap = SetEnvironmentVariable(StrPtr(EnvName), StrPtr(out))
    End Function
    Private Function GetPrevHeap() As Long
        Dim out         As String
        out = Space(&H8)
        If GetEnvironmentVariable(StrPtr(EnvName), StrPtr(out), LenB(out)) Then GetPrevHeap = Val("&H" & out)
    End Function
    Private Function CreateStackConv(ByVal ptr As Long) As Boolean
        Dim lpMeth      As Long
        Dim vTable      As Long
        
        GetMem4 ByVal ObjPtr(Me), vTable
        GetMem4 ByVal vTable + WNDPROCINDEX * 4 + &H1C, lpMeth
        
        GetMem4 &H5450C031, ByVal ptr + &H0:    GetMem4 &H488DE409, ByVal ptr + &H4:    GetMem4 &H2474FF06, ByVal ptr + &H8
        GetMem4 &H68FAE020, ByVal ptr + &HC:    GetMem4 &H12345678, ByVal ptr + &H10:   GetMem4 &HFFFFE7E8, ByVal ptr + &H14
        GetMem4 &H18C258FF, ByVal ptr + &H18:   GetMem4 &H0, ByVal ptr + &H1C
    
        GetMem4 ObjPtr(Me), ByVal ptr + &H10                    ' Push Me
        GetMem4 lpMeth - (ptr + &H14) - 5, ByVal ptr + &H14 + 1 ' Call SUBCLASSPROC
        
    End Function
     
    Private Function CreateIDEStub(ByVal ptr As Long) As Boolean
        Dim hInstVB6    As Long
        Dim lpEbMode    As Long
        Dim hComctl32   As Long
        Dim lpDefProc   As Long
        Dim lpRemove    As Long
        
        hInstVB6 = GetModuleHandle(StrPtr("vba6"))
        If hInstVB6 = 0 Then Exit Function
        hComctl32 = GetModuleHandle(StrPtr("Comctl32"))
        If hComctl32 = 0 Then
            hComctl32 = LoadLibrary(StrPtr("Comctl32"))
            If hComctl32 = 0 Then Exit Function
        End If
        
        lpEbMode = GetProcAddress(hInstVB6, "EbMode")
        If lpEbMode = 0 Then Exit Function
        lpDefProc = GetProcAddress(hComctl32, "DefSubclassProc")
        If lpDefProc = 0 Then Exit Function
        lpRemove = GetProcAddress(hComctl32, "RemoveWindowSubclass")
        If lpRemove = 0 Then Exit Function
        
        GetMem4 &HFFFFFBE8, ByVal ptr + &H0:    GetMem4 &H74C084FF, ByVal ptr + &H4:    GetMem4 &H74013C1C, ByVal ptr + &H8
        GetMem4 &H2474FF33, ByVal ptr + &HC:    GetMem4 &H2474FF10, ByVal ptr + &H10:   GetMem4 &H2474FF10, ByVal ptr + &H14
        GetMem4 &H2474FF10, ByVal ptr + &H18:   GetMem4 &HFFDEE810, ByVal ptr + &H1C:   GetMem4 &H18C2FFFF, ByVal ptr + &H20
        GetMem4 &HDFF00, ByVal ptr + &H24:      GetMem4 &H68000000, ByVal ptr + &H28:   GetMem4 &H12345678, ByVal ptr + &H2C
        GetMem4 &H34567868, ByVal ptr + &H30:   GetMem4 &H2474FF12, ByVal ptr + &H34:   GetMem4 &HFFC2E80C, ByVal ptr + &H38
        GetMem4 &HCDEBFFFF, ByVal ptr + &H3C:
    
        GetMem4 lpEbMode - ptr - 5, ByVal ptr + 1 + 0                   ' Call EbMode
        GetMem4 lpDefProc - (ptr + &H1D) - 5, ByVal ptr + &H1D + 1      ' Call DefSubclassProc
        GetMem4 lpRemove - (ptr + &H39) - 5, ByVal ptr + &H39 + 1       ' Call RemoveWindowSubclass
        GetMem4 ObjPtr(Me), ByVal ptr + &H2C                            ' Push uIdSubclass
        GetMem4 ptr, ByVal ptr + &H31                                   ' Push pfnSubclass
        GetMem4 GetFlagPointer(), ByVal ptr + &H27                      ' dec dword [flag]
        
        CreateIDEStub = True
    End Function
    Private Function MakeTrue(Value As Boolean) As Boolean: Value = True: MakeTrue = True: End Function
    Attached Files Attached Files

  5. #5
    PowerPoster
    Join Date
    Jun 2015
    Posts
    2,224

    Re: [VB6] - Class for subclassing windows and classes.

    I like that you have it encompassed in a single class, but I hate the fact that it has to use a modified assembly stub to do it.
    Also the Overhead of using COM Events to do the callback makes me cringe, but modern processors probably make that point moot.
    Last edited by DEXWERX; Jun 25th, 2015 at 10:42 AM. Reason: Deleted link to someone elses method

  6. #6

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,353

    Re: [VB6] - Class for subclassing windows and classes.

    VERSION 2.1

    More stable solution. Now you can use the "End" statement for the ending and use the "MsgBox". Also you can't worry about the errors and handle them as usual.

    Code:
    Option Explicit
    
    ' clsTrickSubclass2.cls - class for window subclassing
    ' © Krivous Anatolii Anatolevich (The trick), 2015
    ' Version 2.1
    
    Private Type PROCESS_HEAP_ENTRY
        lpData              As Long
        cbData              As Long
        cbOverhead          As Byte
        iRegionIndex        As Byte
        wFlags              As Integer
        dwCommittedSize     As Long
        dwUnCommittedSize   As Long
        lpFirstBlock        As Long
        lpLastBlock         As Long
    End Type
    
    Private Declare Function SetWindowSubclass Lib "Comctl32" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, dwRefData As Any) As Long
    Private Declare Function RemoveWindowSubclass Lib "Comctl32" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
    Private Declare Function DefSubclassProc Lib "Comctl32" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As Long) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As Long) As Long
    Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
    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 HeapWalk Lib "kernel32" (ByVal hHeap As Long, ByRef lpEntry As PROCESS_HEAP_ENTRY) As Long
    Private Declare Function HeapLock Lib "kernel32" (ByVal hHeap As Long) As Long
    Private Declare Function HeapUnlock Lib "kernel32" (ByVal hHeap As Long) As Long
    Private Declare Function SetEnvironmentVariable Lib "kernel32" Alias "SetEnvironmentVariableW" (ByVal lpName As Long, ByVal lpValue As Long) As Long
    Private Declare Function GetEnvironmentVariable Lib "kernel32" Alias "GetEnvironmentVariableW" (ByVal lpName As Long, ByVal lpBuffer As Long, ByVal nSize As Long) As Long
    Private Declare Function GetMem4 Lib "msvbvm60" (pSrc As Any, pDst As Any) As Long
    
    Private Const WM_CREATE                     As Long = &H1
    Private Const WM_DESTROY                    As Long = &H2
    Private Const GCL_WNDPROC                   As Long = (-24)
    Private Const GWL_WNDPROC                   As Long = (-4)
    Private Const HEAP_CREATE_ENABLE_EXECUTE    As Long = &H40000
    Private Const HEAP_NO_SERIALIZE             As Long = &H1
    Private Const HEAP_ZERO_MEMORY              As Long = &H8
    Private Const PROCESS_HEAP_ENTRY_BUSY       As Long = &H4
    Private Const WNDPROCINDEX                  As Long = 8
    Private Const EnvName                       As String = "TrickSubclass"
    
    Public Event WndProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, Ret As Long, DefCall As Boolean)
    
    Private mIsSubclassed   As Boolean
    Private mhWnd           As Long
    Private mIsPaused       As Boolean
    
    Dim hHeap   As Long
    Dim lpAsm   As Long
    
    ' Return a window handle
    Public Property Get hWnd() As Long
        hWnd = mhWnd
    End Property
    ' Subclassing state (True - subclassing on)
    Public Property Get IsSubclassed() As Boolean
        IsSubclassed = mIsSubclassed
    End Property
    ' Pause subclassing
    Public Function PauseSubclass() As Boolean
        If mIsSubclassed And Not mIsPaused Then mIsPaused = True: PauseSubclass = True
    End Function
    ' Resume
    Public Function ResumeSubclass() As Boolean
        If mIsSubclassed And mIsPaused Then mIsPaused = False: ResumeSubclass = True
    End Function
    ' If pause then return True
    Public Property Get IsPaused() As Boolean
        IsPaused = mIsPaused
    End Property
    ' Set subclassing to window (if subclassing already enabled then remove it)
    Public Function Hook(ByVal hWnd As Long) As Boolean
    
        If mIsSubclassed Then
            If Not UnHook Then Exit Function
        End If
        
        If CreateAsm Then
        
            mIsSubclassed = SetWindowSubclass(hWnd, lpAsm, ObjPtr(Me), 0)
            
            If mIsSubclassed Then
                Hook = True
                mhWnd = hWnd
            End If
            
        End If
        
    End Function
    ' Remove subclassing
    Public Function UnHook() As Boolean
        If Not mIsSubclassed Then Exit Function
        UnHook = RemoveWindowSubclass(mhWnd, lpAsm, ObjPtr(Me))
        If UnHook Then mhWnd = 0: mIsSubclassed = False
    End Function
    ' Call default procedure
    Public Function CallDef(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, ByRef Status As Boolean) As Long
        If Not mIsSubclassed Then Exit Function
        CallDef = DefSubclassProc(hWnd, Msg, wParam, lParam)
        Status = True
    End Function
    
    ' --------------------------------------------------------------------------------------------------------------------------------------
    Private Function SUBCLASSPROC(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
        
        If mIsPaused Then
            SUBCLASSPROC = DefSubclassProc(hWnd, Msg, wParam, lParam)
        Else
            Dim DefCall As Boolean
            DefCall = True
            RaiseEvent WndProc(hWnd, Msg, wParam, lParam, SUBCLASSPROC, DefCall)
            If DefCall Then SUBCLASSPROC = DefSubclassProc(hWnd, Msg, wParam, lParam)
        End If
        
    End Function
    Private Sub Class_Terminate()
        If hHeap = 0 Then Exit Sub
        UnHook
        If CountHooks = 1 Then
            HeapDestroy hHeap
            hHeap = 0
            SaveCurHeap
        Else
            HeapFree hHeap, HEAP_NO_SERIALIZE, ByVal lpAsm
        End If
    End Sub
    Private Function CreateAsm() As Boolean
        Dim inIDE   As Boolean
        Dim AsmSize As Long
        Dim ptr     As Long
        Dim isFirst As Boolean
    
        Debug.Assert MakeTrue(inIDE)
        
        If lpAsm = 0 Then
            If inIDE Then AsmSize = &H5E Else AsmSize = &H1D
            hHeap = GetPrevHeap()
            
            If hHeap Then
                If inIDE Then
                    Dim flag    As Long
                    ptr = GetFlagPointer()
                    GetMem4 ByVal ptr, flag
                    If flag Then
                        HeapDestroy hHeap
                        isFirst = True
                    End If
                End If
            Else: isFirst = True
            End If
            
            If isFirst Then
                hHeap = HeapCreate(HEAP_CREATE_ENABLE_EXECUTE Or HEAP_NO_SERIALIZE, 0, 0)
                If hHeap = 0 Then Err.Raise 7: Exit Function
                If Not SaveCurHeap() Then HeapDestroy hHeap: hHeap = 0: Err.Raise 7: Exit Function
                AsmSize = AsmSize + &H4
            End If
            
            lpAsm = HeapAlloc(hHeap, HEAP_NO_SERIALIZE Or HEAP_ZERO_MEMORY, AsmSize)
            
            If lpAsm = 0 Then
                If isFirst Then HeapDestroy hHeap
                hHeap = 0
                Err.Raise 7
                Exit Function
            End If
            
            Dim prv As Long
            Dim i   As Long
            
            If inIDE Then
                If isFirst Then
                    GetMem4 0&, ByVal lpAsm
                    lpAsm = lpAsm + 4
                End If
            End If
            
        End If
        
        ptr = lpAsm
        
        If inIDE Then
            CreateIDEStub (ptr): ptr = ptr + &H40
        End If
        
        CreateStackConv ptr
        CreateAsm = True
        
    End Function
    Private Function GetFlagPointer() As Long
        Dim he  As PROCESS_HEAP_ENTRY
        HeapLock hHeap
        Do While HeapWalk(hHeap, he)
            If he.wFlags And PROCESS_HEAP_ENTRY_BUSY Then GetFlagPointer = he.lpData: Exit Function
        Loop
        HeapUnlock hHeap
    End Function
    Private Function CountHooks() As Long
        Dim he  As PROCESS_HEAP_ENTRY
        HeapLock hHeap
        Do While HeapWalk(hHeap, he)
            If he.wFlags And PROCESS_HEAP_ENTRY_BUSY Then CountHooks = CountHooks + 1
        Loop
        HeapUnlock hHeap
    End Function
    Private Function SaveCurHeap() As Boolean
        Dim i   As Long
        Dim out As String
        out = Hex(hHeap)
        For i = Len(out) + 1 To 8: out = "0" & out: Next
        SaveCurHeap = SetEnvironmentVariable(StrPtr(EnvName), StrPtr(out))
    End Function
    Private Function GetPrevHeap() As Long
        Dim out         As String
        out = Space(&H8)
        If GetEnvironmentVariable(StrPtr(EnvName), StrPtr(out), LenB(out)) Then GetPrevHeap = Val("&H" & out)
    End Function
    Private Function CreateStackConv(ByVal ptr As Long) As Boolean
        Dim lpMeth      As Long
        Dim vTable      As Long
        
        GetMem4 ByVal ObjPtr(Me), vTable
        GetMem4 ByVal vTable + WNDPROCINDEX * 4 + &H1C, lpMeth
        
        GetMem4 &H5450C031, ByVal ptr + &H0:    GetMem4 &H488DE409, ByVal ptr + &H4:    GetMem4 &H2474FF06, ByVal ptr + &H8
        GetMem4 &H68FAE020, ByVal ptr + &HC:    GetMem4 &H12345678, ByVal ptr + &H10:   GetMem4 &HFFFFE7E8, ByVal ptr + &H14
        GetMem4 &H18C258FF, ByVal ptr + &H18:   GetMem4 &H0, ByVal ptr + &H1C
    
        GetMem4 ObjPtr(Me), ByVal ptr + &H10                    ' Push Me
        GetMem4 lpMeth - (ptr + &H14) - 5, ByVal ptr + &H14 + 1 ' Call SUBCLASSPROC
        
    End Function
     
    Private Function CreateIDEStub(ByVal ptr As Long) As Boolean
        Dim hInstVB6    As Long
        Dim lpEbMode    As Long
        Dim hComctl32   As Long
        Dim lpDefProc   As Long
        Dim lpRemove    As Long
        
        hInstVB6 = GetModuleHandle(StrPtr("vba6"))
        If hInstVB6 = 0 Then Exit Function
        hComctl32 = GetModuleHandle(StrPtr("Comctl32"))
        If hComctl32 = 0 Then
            hComctl32 = LoadLibrary(StrPtr("Comctl32"))
            If hComctl32 = 0 Then Exit Function
        End If
        
        lpEbMode = GetProcAddress(hInstVB6, "EbMode")
        If lpEbMode = 0 Then Exit Function
        lpDefProc = GetProcAddress(hComctl32, "DefSubclassProc")
        If lpDefProc = 0 Then Exit Function
        lpRemove = GetProcAddress(hComctl32, "RemoveWindowSubclass")
        If lpRemove = 0 Then Exit Function
        
        GetMem4 &HFFFFFBE8, ByVal ptr + &H0:    GetMem4 &H74C084FF, ByVal ptr + &H4:    GetMem4 &H74013C1C, ByVal ptr + &H8
        GetMem4 &H2474FF33, ByVal ptr + &HC:    GetMem4 &H2474FF10, ByVal ptr + &H10:   GetMem4 &H2474FF10, ByVal ptr + &H14
        GetMem4 &H2474FF10, ByVal ptr + &H18:   GetMem4 &HFFDEE810, ByVal ptr + &H1C:   GetMem4 &H18C2FFFF, ByVal ptr + &H20
        GetMem4 &HDFF00, ByVal ptr + &H24:      GetMem4 &H68000000, ByVal ptr + &H28:   GetMem4 &H12345678, ByVal ptr + &H2C
        GetMem4 &H34567868, ByVal ptr + &H30:   GetMem4 &H2474FF12, ByVal ptr + &H34:   GetMem4 &HFFC2E80C, ByVal ptr + &H38
        GetMem4 &HCDEBFFFF, ByVal ptr + &H3C:
    
        GetMem4 lpEbMode - ptr - 5, ByVal ptr + 1 + 0                   ' Call EbMode
        GetMem4 lpDefProc - (ptr + &H1D) - 5, ByVal ptr + &H1D + 1      ' Call DefSubclassProc
        GetMem4 lpRemove - (ptr + &H39) - 5, ByVal ptr + &H39 + 1       ' Call RemoveWindowSubclass
        GetMem4 ObjPtr(Me), ByVal ptr + &H2C                            ' Push uIdSubclass
        GetMem4 ptr, ByVal ptr + &H31                                   ' Push pfnSubclass
        GetMem4 GetFlagPointer(), ByVal ptr + &H27                      ' dec dword [flag]
        
        CreateIDEStub = True
    End Function
    Private Function MakeTrue(Value As Boolean) As Boolean: Value = True: MakeTrue = True: End Function
    Attached Files Attached Files

  7. #7
    New Member Dimio's Avatar
    Join Date
    Nov 2015
    Posts
    2

    Re: [VB6] - Class for subclassing windows and classes.

    Your work is very good... anyway I think to have found a little bug.
    1. Create an Usercontrol
    2. Use your class to subclass the main form.
    3. Compile the project
    When you close the program it crashes.
    Attached Files Attached Files

  8. #8

  9. #9
    VB-aholic & Lovin' It LaVolpe's Avatar
    Join Date
    Oct 2007
    Location
    Beside Waldo
    Posts
    18,378

    Re: [VB6] - Class for subclassing windows and classes.

    @Trick. Don't know if this applies to the project. But if multiple instances of subclassing is in play and the subclassing is not released in the opposite order, exactly, crashes occur. This has always been an issue with old-school subclassing ... the subclassing chain gets broken. This can occur in a VB project rather easily if VB does not unload the controls in opposite order that the controls first started subclassing. In other words, more times than not, it is likely an issue with the user not the code/thunk. Just my two cents.

    Edited: Ignore my reply, should've taken the couple minutes to download & review the sample project before I replied. Apologize.
    Last edited by LaVolpe; Nov 29th, 2015 at 02:32 PM.
    Insomnia is just a byproduct of, "It can't be done"

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

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


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

  10. #10

  11. #11
    New Member Dimio's Avatar
    Join Date
    Nov 2015
    Posts
    2

    Re: [VB6] - Class for subclassing windows and classes.

    The crash occurs when you try to destroy the heap.
    If you replace:

    Code:
    Private Sub Class_Terminate()
        If hHeap = 0 Then Exit Sub
        UnHook
        If CountHooks = 1 Then
            HeapDestroy hHeap
            hHeap = 0
            SaveCurHeap
        Else
            HeapFree hHeap, HEAP_NO_SERIALIZE, ByVal lpAsm
        End If
    End Sub
    with this:

    Code:
    Private Sub Class_Terminate()
        If hHeap = 0 Then Exit Sub
        UnHook
        HeapFree hHeap, HEAP_NO_SERIALIZE, ByVal lpAsm
        hHeap = 0
    End Sub
    The crash don't occours anymore, although it could cause additional collateral damage.

  12. #12

  13. #13

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,353

    Re: [VB6] - Class for subclassing windows and classes.

    VERSION 2.2
    Fixed previous bug. The class works more stable now.
    There are the example of subclassing the parent form from an usercontrol in the attached archive.
    Code:
    Option Explicit
    
    ' clsTrickSubclass2.cls - class for window subclassing
    ' © Krivous Anatolii Anatolevich (The trick), 2015-2016
    ' Version 2.2
    
    Private Type PROCESS_HEAP_ENTRY
        lpData              As Long
        cbData              As Long
        cbOverhead          As Byte
        iRegionIndex        As Byte
        wFlags              As Integer
        dwCommittedSize     As Long
        dwUnCommittedSize   As Long
        lpFirstBlock        As Long
        lpLastBlock         As Long
    End Type
    
    Private Declare Function SetWindowSubclass Lib "Comctl32" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, dwRefData As Any) As Long
    Private Declare Function RemoveWindowSubclass Lib "Comctl32" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
    Private Declare Function DefSubclassProc Lib "Comctl32" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As Long) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As Long) As Long
    Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
    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 HeapWalk Lib "kernel32" (ByVal hHeap As Long, ByRef lpEntry As PROCESS_HEAP_ENTRY) As Long
    Private Declare Function HeapLock Lib "kernel32" (ByVal hHeap As Long) As Long
    Private Declare Function HeapUnlock Lib "kernel32" (ByVal hHeap As Long) As Long
    Private Declare Function SetEnvironmentVariable Lib "kernel32" Alias "SetEnvironmentVariableW" (ByVal lpName As Long, ByVal lpValue As Long) As Long
    Private Declare Function GetEnvironmentVariable Lib "kernel32" Alias "GetEnvironmentVariableW" (ByVal lpName As Long, ByVal lpBuffer As Long, ByVal nSize As Long) As Long
    Private Declare Function GetMem4 Lib "msvbvm60" (pSrc As Any, pDst As Any) As Long
    
    Private Const WM_CREATE                     As Long = &H1
    Private Const WM_DESTROY                    As Long = &H2
    Private Const GCL_WNDPROC                   As Long = (-24)
    Private Const GWL_WNDPROC                   As Long = (-4)
    Private Const HEAP_CREATE_ENABLE_EXECUTE    As Long = &H40000
    Private Const HEAP_NO_SERIALIZE             As Long = &H1
    Private Const HEAP_ZERO_MEMORY              As Long = &H8
    Private Const PROCESS_HEAP_ENTRY_BUSY       As Long = &H4
    Private Const WNDPROCINDEX                  As Long = 8
    Private Const EnvName                       As String = "TrickSubclass"
    
    Public Event WndProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, Ret As Long, DefCall As Boolean)
    
    Private mIsSubclassed   As Boolean
    Private mhWnd           As Long
    Private mIsPaused       As Boolean
    Private mTerminateFlag  As Boolean
    Private mDepth          As Long
    Private mSelf           As clsTrickSubclass2
    
    Dim hHeap   As Long
    Dim lpAsm   As Long
    
    ' Return a window handle
    Public Property Get hWnd() As Long
        hWnd = mhWnd
    End Property
    ' Subclassing state (True - subclassing on)
    Public Property Get IsSubclassed() As Boolean
        IsSubclassed = mIsSubclassed
    End Property
    ' Pause subclassing
    Public Function PauseSubclass() As Boolean
        If mIsSubclassed And Not mIsPaused Then mIsPaused = True: PauseSubclass = True
    End Function
    ' Resume
    Public Function ResumeSubclass() As Boolean
        If mIsSubclassed And mIsPaused Then mIsPaused = False: ResumeSubclass = True
    End Function
    ' If pause then return True
    Public Property Get IsPaused() As Boolean
        IsPaused = mIsPaused
    End Property
    ' Set subclassing to window (if subclassing already enabled then remove it)
    Public Function Hook(ByVal hWnd As Long) As Boolean
    
        If mIsSubclassed Then
            If Not UnHook Then Exit Function
        End If
        
        If CreateAsm Then
            
            Debug.Print Hex(lpAsm)
            
            mIsSubclassed = SetWindowSubclass(hWnd, lpAsm, ObjPtr(Me), 0)
            
            If mIsSubclassed Then
                Hook = True
                mhWnd = hWnd
            End If
            
        End If
        
    End Function
    ' Remove subclassing
    Public Function UnHook() As Boolean
        If Not mIsSubclassed Then Exit Function
        UnHook = RemoveWindowSubclass(mhWnd, lpAsm, ObjPtr(Me))
        If UnHook Then mhWnd = 0: mIsSubclassed = False
    End Function
    ' Call default procedure
    Public Function CallDef(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, ByRef Status As Boolean) As Long
        If Not mIsSubclassed Then Exit Function
        CallDef = DefSubclassProc(hWnd, Msg, wParam, lParam)
        Status = True
    End Function
    
    ' --------------------------------------------------------------------------------------------------------------------------------------
    Private Function SUBCLASSPROC(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 inIDE   As Boolean
        Dim retAddr As Long
        Dim addr    As Long
        
        mDepth = mDepth + 1
        
        If mIsPaused Then
            SUBCLASSPROC = DefSubclassProc(hWnd, Msg, wParam, lParam)
        Else
            Dim DefCall As Boolean
            DefCall = True
            RaiseEvent WndProc(hWnd, Msg, wParam, lParam, SUBCLASSPROC, DefCall)
            If DefCall Then SUBCLASSPROC = DefSubclassProc(hWnd, Msg, wParam, lParam)
        End If
         
        mDepth = mDepth - 1
        
        Debug.Assert MakeTrue(inIDE)
        
        If inIDE Then
            Dim refDat  As Long
            GetMem4 ByVal ObjPtr(Me) + 8, refDat
            GetMem4 ByVal refDat + 4, refDat
            If refDat = 1 Then
                addr = VarPtr(hWnd) + &H20
                GetMem4 ByVal addr, ByVal addr - &H28
            End If
        Else
            If mTerminateFlag And mDepth = 0 Then
                addr = VarPtr(hWnd) + &H20
                GetMem4 ByVal addr, ByVal addr - &H28
                ' // Clean
                Call Class_Terminate
            End If
        End If
        
    End Function
    
    Private Sub Class_Terminate()
    
        If hHeap = 0 Then Exit Sub
        
        UnHook
        
        If mDepth Then
            Set mSelf = Me
            mTerminateFlag = True
        Else
            If CountHooks = 1 Then
                HeapDestroy hHeap
                hHeap = 0
                SaveCurHeap
            Else
                HeapFree hHeap, HEAP_NO_SERIALIZE, ByVal lpAsm
            End If
            Set mSelf = Nothing
        End If
        
    End Sub
    Private Function CreateAsm() As Boolean
        Dim inIDE   As Boolean
        Dim AsmSize As Long
        Dim ptr     As Long
        Dim isFirst As Boolean
    
        Debug.Assert MakeTrue(inIDE)
        
        If lpAsm = 0 Then
            If inIDE Then AsmSize = &H5E Else AsmSize = &H1D
            hHeap = GetPrevHeap()
            
            If hHeap Then
                If inIDE Then
                    Dim flag    As Long
                    ptr = GetFlagPointer()
                    GetMem4 ByVal ptr, flag
                    If flag Then
                        HeapDestroy hHeap
                        isFirst = True
                    End If
                End If
            Else: isFirst = True
            End If
            
            If isFirst Then
                hHeap = HeapCreate(HEAP_CREATE_ENABLE_EXECUTE Or HEAP_NO_SERIALIZE, 0, 0)
                If hHeap = 0 Then Err.Raise 7: Exit Function
                If Not SaveCurHeap() Then HeapDestroy hHeap: hHeap = 0: Err.Raise 7: Exit Function
                AsmSize = AsmSize + &H4
            End If
            
            lpAsm = HeapAlloc(hHeap, HEAP_NO_SERIALIZE Or HEAP_ZERO_MEMORY, AsmSize)
            
            If lpAsm = 0 Then
                If isFirst Then HeapDestroy hHeap
                hHeap = 0
                Err.Raise 7
                Exit Function
            End If
            
            Dim prv As Long
            Dim i   As Long
            
            If inIDE Then
                If isFirst Then
                    GetMem4 0&, ByVal lpAsm
                    lpAsm = lpAsm + 4
                End If
            End If
            
        End If
        
        ptr = lpAsm
        
        If inIDE Then
            CreateIDEStub (ptr): ptr = ptr + &H40
        End If
        
        CreateStackConv ptr
        CreateAsm = True
        
    End Function
    Private Function GetFlagPointer() As Long
        Dim he  As PROCESS_HEAP_ENTRY
        HeapLock hHeap
        Do While HeapWalk(hHeap, he)
            If he.wFlags And PROCESS_HEAP_ENTRY_BUSY Then GetFlagPointer = he.lpData: Exit Function
        Loop
        HeapUnlock hHeap
    End Function
    Private Function CountHooks() As Long
        Dim he  As PROCESS_HEAP_ENTRY
        HeapLock hHeap
        Do While HeapWalk(hHeap, he)
            If he.wFlags And PROCESS_HEAP_ENTRY_BUSY Then CountHooks = CountHooks + 1
        Loop
        HeapUnlock hHeap
    End Function
    Private Function SaveCurHeap() As Boolean
        Dim i   As Long
        Dim out As String
        out = Hex(hHeap)
        For i = Len(out) + 1 To 8: out = "0" & out: Next
        SaveCurHeap = SetEnvironmentVariable(StrPtr(EnvName), StrPtr(out))
    End Function
    Private Function GetPrevHeap() As Long
        Dim out         As String
        out = Space(&H8)
        If GetEnvironmentVariable(StrPtr(EnvName), StrPtr(out), LenB(out)) Then GetPrevHeap = Val("&H" & out)
    End Function
    Private Function CreateStackConv(ByVal ptr As Long) As Boolean
        Dim lpMeth      As Long
        Dim vTable      As Long
        
        GetMem4 ByVal ObjPtr(Me), vTable
        GetMem4 ByVal vTable + WNDPROCINDEX * 4 + &H1C, lpMeth
        
        GetMem4 &H5450C031, ByVal ptr + &H0:    GetMem4 &H488DE409, ByVal ptr + &H4:    GetMem4 &H2474FF06, ByVal ptr + &H8
        GetMem4 &H68FAE020, ByVal ptr + &HC:    GetMem4 &H12345678, ByVal ptr + &H10:   GetMem4 &HFFFFE7E8, ByVal ptr + &H14
        GetMem4 &H18C258FF, ByVal ptr + &H18:   GetMem4 &H0, ByVal ptr + &H1C
    
        GetMem4 ObjPtr(Me), ByVal ptr + &H10                    ' Push Me
        GetMem4 lpMeth - (ptr + &H14) - 5, ByVal ptr + &H14 + 1 ' Call SUBCLASSPROC
        
    End Function
     
    Private Function CreateIDEStub(ByVal ptr As Long) As Boolean
        Dim hInstVB6    As Long
        Dim lpEbMode    As Long
        Dim hComctl32   As Long
        Dim lpDefProc   As Long
        Dim lpRemove    As Long
        
        hInstVB6 = GetModuleHandle(StrPtr("vba6"))
        If hInstVB6 = 0 Then Exit Function
        hComctl32 = GetModuleHandle(StrPtr("Comctl32"))
        If hComctl32 = 0 Then
            hComctl32 = LoadLibrary(StrPtr("Comctl32"))
            If hComctl32 = 0 Then Exit Function
        End If
        
        lpEbMode = GetProcAddress(hInstVB6, "EbMode")
        If lpEbMode = 0 Then Exit Function
        lpDefProc = GetProcAddress(hComctl32, "DefSubclassProc")
        If lpDefProc = 0 Then Exit Function
        lpRemove = GetProcAddress(hComctl32, "RemoveWindowSubclass")
        If lpRemove = 0 Then Exit Function
        
        GetMem4 &HFFFFFBE8, ByVal ptr + &H0:    GetMem4 &H74C084FF, ByVal ptr + &H4:    GetMem4 &H74013C1C, ByVal ptr + &H8
        GetMem4 &H2474FF33, ByVal ptr + &HC:    GetMem4 &H2474FF10, ByVal ptr + &H10:   GetMem4 &H2474FF10, ByVal ptr + &H14
        GetMem4 &H2474FF10, ByVal ptr + &H18:   GetMem4 &HFFDEE810, ByVal ptr + &H1C:   GetMem4 &H18C2FFFF, ByVal ptr + &H20
        GetMem4 &HDFF00, ByVal ptr + &H24:      GetMem4 &H68000000, ByVal ptr + &H28:   GetMem4 &H12345678, ByVal ptr + &H2C
        GetMem4 &H34567868, ByVal ptr + &H30:   GetMem4 &H2474FF12, ByVal ptr + &H34:   GetMem4 &HFFC2E80C, ByVal ptr + &H38
        GetMem4 &HCDEBFFFF, ByVal ptr + &H3C:
    
        GetMem4 lpEbMode - ptr - 5, ByVal ptr + 1 + 0                   ' Call EbMode
        GetMem4 lpDefProc - (ptr + &H1D) - 5, ByVal ptr + &H1D + 1      ' Call DefSubclassProc
        GetMem4 lpRemove - (ptr + &H39) - 5, ByVal ptr + &H39 + 1       ' Call RemoveWindowSubclass
        GetMem4 ObjPtr(Me), ByVal ptr + &H2C                            ' Push uIdSubclass
        GetMem4 ptr, ByVal ptr + &H31                                   ' Push pfnSubclass
        GetMem4 GetFlagPointer(), ByVal ptr + &H27                      ' dec dword [flag]
        
        CreateIDEStub = True
    End Function
    Private Function MakeTrue(Value As Boolean) As Boolean: Value = True: MakeTrue = True: End Function
    Attached Files Attached Files

  14. #14
    Member Dragokas's Avatar
    Join Date
    Aug 2015
    Location
    Ukraine
    Posts
    571

    Re: [VB6] - Class for subclassing windows and classes.

    Anatolii, thank you very much.
    There is no more crashes after closing my application.

  15. #15
    Member Dragokas's Avatar
    Join Date
    Aug 2015
    Location
    Ukraine
    Posts
    571

    Re: [VB6] - Class for subclassing windows and classes.

    Hi, The Trick !

    Please, remove line:
    Code:
    DefCall = True
    from your project

  16. #16

  17. #17
    Member Dragokas's Avatar
    Join Date
    Aug 2015
    Location
    Ukraine
    Posts
    571

    Re: [VB6] - Class for subclassing windows and classes.

    Oh, sorry. Now I noticed that you change 'DefCall' calling model on this version. So, I should use DefCall = false on my window message routine for each caught Msgs where I need it.
    I just replaced old 2.0 code to 2.2. without paying attention on new rules of using.

  18. #18
    New Member
    Join Date
    Aug 2016
    Posts
    5

    Re: [VB6] - Class for subclassing windows and classes.

    Hi,

    There is a little bug

    1. Include a CommandButton -> Command1
    2. Put “End” on “Click” event
    3. Compile the project

    Private Sub Command1_Click()
    End
    End Sub

    When you click on a button (After compiling - Project1.exe) the program it crashes.

    Can you fix it?

  19. #19
    PowerPoster Arnoutdv's Avatar
    Join Date
    Oct 2013
    Posts
    3,596

    Re: [VB6] - Class for subclassing windows and classes.

    Never ever use END in your program, this causes an abnormal termination of the application.

  20. #20
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    5,696

    Re: [VB6] - Class for subclassing windows and classes.

    Yes, without a relatively nasty hack, involving the insertion of machine code in the executable's shutdown procedure, there's no way to fix the damage that an End statement can do.

    Quote from MSDN:
    The End statement stops code execution abruptly, without invoking the Unload, QueryUnload, or Terminate event, or any other Visual Basic code. Code you have placed in the Unload, QueryUnload, and Terminate events of forms and class modules is not executed. Objects created from class modules are destroyed, files opened using the Open statement are closed, and memory used by your program is freed. Object references held by other programs are invalidated.

    The End statement provides a way to force your program to halt. For normal termination of a Visual Basic program, you should unload all forms. Your program closes as soon as there are no other programs holding references to objects created from your public class modules and no code executing.

    (emphasis added)
    Any software I post in these forums written by me is provided “AS IS” without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. Please understand that I’ve been programming since the mid-1970s and still have some of that code. My contemporary VB6 project is approaching 1,000 modules. In addition, I have a “VB6 random code folder” that is overflowing. I’ve been at this long enough to truly not know with absolute certainty from whence every single line of my code has come, with much of it coming from programmers under my employ who signed intellectual property transfers. I have not deliberately attempted to remove any licenses and/or attributions from any software. If someone finds that I have inadvertently done so, I sincerely apologize, and, upon notice and reasonable proof, will re-attach those licenses and/or attributions. To all, peace and happiness.

Tags for this Thread

Posting Permissions

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



Featured


Click Here to Expand Forum to Full Width