[VB6] - Class for subclassing windows and classes.
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.
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.
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
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.
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"
Re: [VB6] - Class for subclassing windows and classes.
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.
Last edited by The trick; Nov 29th, 2015 at 02:42 PM.
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.
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.
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. To all, peace and happiness.
Re: [VB6] - Class for subclassing windows and classes.
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.
Re: [VB6] - Class for subclassing windows and classes.
@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:
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.
Re: [VB6] - Class for subclassing windows and classes.
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).
Re: [VB6] - Class for subclassing windows and classes.
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