[VB6] - Class for subclassing windows and classes.

http://www.youtube.com/watch?v=J5aUQp3bJiU

THE DESCRIPTION IS OUT OF DATE. SEE DESCRIPTION ON GITHUB.

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.
http://www.vbforums.com/images/ieimages/2015/02/1.png
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.

Version 3.0:

• more stable works. Fix previous bugs;
• project is moved to Github.

Project on GitHub.

[not relevant]

[not relevant]

[not relevant]

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.

[not relevant]

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.

Thank for debugging, i'll try to fix this problem.

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

LaVolpe, thank for reply.
I bypassed this problem using SetWindowSubclass. For it doesn't matter the order.
UDP:
I see this problem. It occurs because RemoveWindowsSubclass doesn't remove the subclassing. I didn't understand the reason yet.

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.

Quote:

---

The crash don't occours anymore, although it could cause additional collateral damage.

---

Quote:

---

I see this problem. It occurs because RemoveWindowsSubclass doesn't remove the subclassing. I didn't understand the reason yet.

---

I don't investigate it yet because i don't have enough time. I think i'll fix it after new year.

[not relevant]

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

Hi, The Trick !

Please, remove line:

Code:

---

DefCall = True

---

from your project :)

Quote:

---

Originally Posted by Dragokas

Hi, The Trick !

Please, remove line:

Code:

---

DefCall = True

---

from your project :)

---

Hi!
I can't do it because this assignment ensures the proper work in IDE. If a project is paused DefCall = True ensures CallWindowProc calling.

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.

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?

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

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:

Quote:

---

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)

---

in one of my project, which is an addin project of msword
it crash sometimes

@The trick
You probably shouldn't use HeapLock and HeapUnlock when creating the heap with the HEAP_NO_SERIALIZE flag as stated in the MSDN:

Quote:

---

If the HeapLock and HeapUnlock functions are called on a heap created with the HEAP_NO_SERIALIZE flag, the results are undefined.

---

Quote:

---

Originally Posted by Caine

@The trick
You probably shouldn't use HeapLock and HeapUnlock when creating the heap with the HEAP_NO_SERIALIZE flag as stated in the MSDN:

---

This quote is so out of context it got me baffled at first. The idea is that only if HeapLock and HeapUnlock are called from multiple threads them using HEAP_NO_SERIALIZE flag will *not* guard the heap against corruption so the results are undefined.

If you are not using the heap from multiple threads (as is usually the case with every VB6 application) then using HEAP_NO_SERIALIZE allows for a small performance optimization by not using primitives for serialization of these threads when accessing the heap's internal structures.

"Serialized access" means one after the other, not both threads simultaneously modifying the (same) heap management structure.

cheers,
</wqw>

@wqweto
I understand the part with the performance optimization. I just don't get this part:

Code:

---

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

---

MSDN states that every HeapLock should be balanced with a HeapUnlock. On the other hand, since no other threads will attempt to access the heap that's probably OKish.

Here's a more complete quote:

Quote:

---

Setting HEAP_NO_SERIALIZE eliminates mutual exclusion on the heap. Without serialization, two or more threads that use the same heap handle might attempt to allocate or free memory simultaneously, which may cause corruption in the heap. Therefore, HEAP_NO_SERIALIZE can safely be used only in the following situations:

The process has only one thread.
The process has multiple threads, but only one thread calls the heap functions for a specific heap.
The process has multiple threads, and the application provides its own mechanism for mutual exclusion to a specific heap.

If the HeapLock and HeapUnlock functions are called on a heap created with the HEAP_NO_SERIALIZE flag, the results are undefined.

---

Since both HeapCreate and HeapAlloc used the HEAP_NO_SERIALIZE flag, the wording here sounds to me like calling HeapLock and HeapUnlock might work or not.

If I understood you correctly, you're saying that calling HeapLock and HeapUnlock will just work but they won't really protect the heap from corruption with the flag specified? I get that the point is probably moot since this is only called from one thread but I'm trying to understand what's happening here.

Quote:

---

Originally Posted by Caine

If I understood you correctly, you're saying that calling HeapLock and HeapUnlock will just work but they won't really protect the heap from corruption with the flag specified? I get that the point is probably moot since this is only called from one thread but I'm trying to understand what's happening here.

---

What I'm saying is that HEAP_NO_SERIALIZE flag is a safe optimization when heap is *not* accessed/locked/performed any modifications of its internal structs by multiple threads simultaneously which is the case in 99% of all VB6 applications (rarely there might be in-process multi-threading implemented).

cheers,
</wqw>

Quote:

---

Originally Posted by The trick

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!

Attachment 123641

---

how to hook for usercontrol?
I WANT TO GET MOUSE EVENT WM_LBUTTONDOWN ，In the form design mode, the mouse event of the custom control

how to make SSTab by vb6 usercontrol?-VBForums
https://www.vbforums.com/showthread....b6-usercontrol

New version 3.0

1. More stable;
2. Optimized code;
3. Project is moved to Github.

See the first post to download the latest version.

Cool! Thanks.