Форум программистов, компьютерный форум, киберфорум
The trick
Войти
Регистрация
Восстановить пароль
Оценить эту запись

Класс для сабклассинга окон и классов.

Запись от The trick размещена 16.06.2014 в 00:58
Обновил(-а) The trick 12.01.2016 в 18:19



Разработал класс с помощью которого можно работать с сабклассингом. Класс имеет событие WndProc, которое вызывается при получении окном сообщения. Также имеется возможность поставить сабклассинг на класс окон. Имеются методы для приостановки сабклассинга и снятия его, а также получения информации о сабклассинге. Работать очень удобно, т.к. можно останавливать проект кнопкой стоп без последствий. Запускать лучше через Start with full compile, т.к. это предотвратит вылеты, при неудачной компиляции. Я себе вообще вывел отдельно кнопку рядом с обычной компиляцией, и пользуюсь ей.
Название: Безымянный2.png
Просмотров: 2996

Размер: 1.9 Кб
Немного о работе с классом. Для установки сабклассинга на окно, вызывается метод Hook, с хендлом окна. Если метод возвращает True, значит сабклассинг установлен. Обрабатывая событие WndProc, можно изменять поведение окна. В аргумент Ret можно передавать возвращаемое значение, если нужно вызвать процедуру по умолчанию, то нужно передать в аргументе DefCall True.
Для установки сабклассинга на группу окон (класс), нужно вызвать метод HookClass, передавая хендл окна чей класс нужно засабклассировать. При удачном выполнении метод вернет True. Сабклассинг будет действовать начиная со следующего созданного окна этого класса, т.е. на переданный параметр сабклассинг действовать не будет. Также по умолчанию этот вид сабклассинга приостановлен. Я сделал это из-за того, что если не обработать сообщения создания окон должным образом, то проект не запустится с ошибкой Out of memory.
Для снятия сабклассинга нужно вызвать метод Unhook, возвращающий True при удачном выполнении.
Для приостановки и возобновления сабклассинга предусмотрены методы PauseSubclass и ResumeSubclass, возвращающие True при удачном выполнении.
Свойство hWnd возвращает хендл окна, на который установлен сабклассинг (для случая установки сабклассинга на класс окон, возвращает переданный параметр).
Свойство IsSubclassed предназначено для определения, установлен ли сабклассинг или нет.
Свойство IsClass возвращает True, если сабклассинг устанавливался на класс окон.
Свойство IsPaused возвращает True, если сабклассинг приостановлен.

Версия 1.1:
  • добавлен метод CallDef, позволяющий вызвать предыдущую процедуру окна, для заданного сообщения.
  • добавлено свойство Previous, которое возвращает адрес предыдущей оконной процедуры.
  • добавлено свойство Current, которое возвращает адрес текущей оконной процедуры.
Версия 2.0:
  • Убраны методы для работы с классами окон.
  • Реализация работает более стабильно т.к. применен другой способ сабклассинга (SetWindowSubclass)
Версия 2.1:
  • Еще более стабильная работа. Можно не беспокоится об ошибках и спокойно жать End, а также редактировать код и вызывать MsgBox.
Версия 2.2:
  • Еще более стабильная работа. Вылечены предыдущие баги.

Исходный код модуля clsTrickSubclass2.cls:
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
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
Обновления:
18.07.14 - версия 1.1
23.06.15 - версия 2.0
13.11.15 - версия 2.1
12.01.16 - версия 2.2
Вложения
Тип файла: rar TrickSubClass.rar (20.0 Кб, 643 просмотров)
Тип файла: zip Ver. 2_1.zip (6.2 Кб, 140 просмотров)
Тип файла: zip Ver. 2_2.zip (6.5 Кб, 167 просмотров)
Размещено в Без категории
Показов 5189 Комментарии 7
Всего комментариев 7
Комментарии
  1. Старый комментарий
    ...
    Запись от Антихакер32 размещена 16.06.2014 в 02:34 Антихакер32 вне форума
    Обновил(-а) Антихакер32 16.06.2014 в 03:26
  2. Старый комментарий
    Аватар для Dragokas
    Что означает выделенное:
    Цитата:
    В аргумент Ret можно передавать возвращаемое значение, если нужно вызвать процедуру по умолчанию, то нужно передать в аргументе DefCall True.
    Запись от Dragokas размещена 18.07.2014 в 01:49 Dragokas вне форума
  3. Старый комментарий
    Цитата:
    Сообщение от Dragokas Просмотреть комментарий
    Что означает выделенное:
    Т.е. если ты не хочешь обрабатывать процедуру, а оставить ее по умолчанию (то бишь вызвать CallWindowProc с процедурой по умолчанию), то DefCall = True. Например ты сабклассишь форму, для того чтобы ограничить изменяемые размеры, тебе нужно только WM_GETMINMAXINFO, а например WM_PAINT (отрисовка) тебе не нужен, т.е. он должен отрисовываться по старому. Значит обрабатываешь WM_GETMINMAXINFO, а для WM_PAINT делаешь DefCall = True. Желательно для всех неиспользуемых сообщений ставить DefCall.
    Запись от The trick размещена 18.07.2014 в 01:54 The trick вне форума
  4. Старый комментарий
    Аватар для Dragokas
    Правильно ли я понимаю, что, если я не пишу DefCall = True, то мое сообщение дальше не проходит ?
    Запись от Dragokas размещена 18.07.2014 в 18:42 Dragokas вне форума
  5. Старый комментарий
    Цитата:
    Сообщение от Dragokas Просмотреть комментарий
    Правильно ли я понимаю, что, если я не пишу DefCall = True, то мое сообщение дальше не проходит ?
    Да.
    Запись от The trick размещена 18.07.2014 в 18:45 The trick вне форума
  6. Старый комментарий
    Аватар для Dragokas
    Привет, Анатолий!

    А реально, дописать сюда альтернативную ветвь для поддержки Windows 2000,
    заменив SetWindowSubclass на SetWindowLong? А то в этой системе SetWindowSubclass нету.
    Твоя первая версия на Win2000 работает хорошо.
    Запись от Dragokas размещена 02.11.2016 в 03:55 Dragokas вне форума
  7. Старый комментарий
    Аватар для Dragokas
    Разобрался. В Windows 2000 нужно было экспортировать по ординалу.

    Visual Basic
    1
    2
    3
    
    Private Declare Function SetWindowSubclass Lib "Comctl32" Alias "#410" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, dwRefData As Any) As Long
    Private Declare Function RemoveWindowSubclass Lib "Comctl32" Alias "#412" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
    Private Declare Function DefSubclassProc Lib "Comctl32" Alias "#413" (ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Запись от Dragokas размещена 29.11.2016 в 22:35 Dragokas вне форума
 
КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2021, vBulletin Solutions, Inc.