Класс для работы с сабклассингом.

[The trick]

ОПИСАНИЕ УСТАРЕЛО. АКТУАЛЬНОЕ ОПИСАНИЕ НА GITHUB.

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

Немного о работе с классом. Для установки сабклассинга на окно, вызывается метод 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:

• Еще более стабильная работа. Вылечены предыдущие баги.

Версия 3.0:

• Еще более стабильная работа. Вылечены предыдущие баги. Полностью переписан код. Проект переехал на GitHub

Последняя версия.

Обновления:

• 18.07.14 - версия 1.1
  23.06.15 - версия 2.0
  13.11.15 - версия 2.1
  12.01.16 - версия 2.2
  21.11.21 - версия 3.0

[Mikle]

Скачал, на вникая запустил EXE, свернул окно, попутался развернуть - "runtime error 5", причём это сообщение штатно не закрывается, пришлось снимать задачу.

[The trick]

Mikle, спасибо исправил.

[bon818]

Mikle, спасибо исправил.

А вот и не исправил.

Код: Выделить всё

'дежурный код проверки сабклассингов
Private Sub Command1_Click()
    Dim a As Integer: a = a / 0
End Sub


нажатие на Command1_Click при отладке, сабклассинг рушит IDE
но еще хуже что в скомпилированном виде виснет намертво.
ХР SP3

[The trick]

нажатие на Command1_Click при отладке, сабклассинг рушит IDE
но еще хуже что в скомпилированном виде виснет намертво.
ХР SP3

Исправил.

[The trick]

Добавлена новая версия 2.2.

[ger_kar]

Всем привет. Решил использовать данный класс, для эксперимента. Раньше я его уже использовал и все было Ок. Нынче же скачал версию 2.2 и ... Поймал глюк. В демо примере вызов дефолтной оконной процедуры осуществляется посредством выставления флага DefCall в обработчике события. При таком использовании все работает замечательно. Но если отказаться от этой опции и вызывать дефолтную процедуру посредством метода
CallDef hWnd, Msg, wParam, lParam, Status,
то сразу все перестает работать. Интерфейс среды разработки перестает реагировать на мышь и клавиатуру. Сама открытая форма реагирует только на скроллинг колесиком мышки и на этом все. Проект удается закрыть только через диспетчер задач.
Возможно, для большинства случаев применения сабклассинга, удобнее использовать метод с выставлением флага в обработчике. Раньше я так и делал и проблем не возникало. Но для моего эксперимента такой способ не подходит и мне нужен был непосредственный вызов.
Суть эксперимента в следующем: Есть сторонний контрол (Grid), который может прокручивать содержимое либо на одну запись, либо на страницу. Никаких опций настройки скроллинга у него нет. Так вот, посредством сабклассинга хотел перехватывать сообщение WM_MOUSEWHEEL и вызывать дефолтную процедуру, не один раз, а три раза. По идее это должно приводить к скроллингу содержимого грида сразу на три записи (как мне и нужно по задумке), но вышел облом.

[The trick]

Всем привет. Решил использовать данный класс, для эксперимента. Раньше я его уже использовал и все было Ок. Нынче же скачал версию 2.2 и ... Поймал глюк. В демо примере вызов дефолтной оконной процедуры осуществляется посредством выставления флага DefCall в обработчике события. При таком использовании все работает замечательно. Но если отказаться от этой опции и вызывать дефолтную процедуру посредством метода
CallDef hWnd, Msg, wParam, lParam, Status,
то сразу все перестает работать. Интерфейс среды разработки перестает реагировать на мышь и клавиатуру. Сама открытая форма реагирует только на скроллинг колесиком мышки и на этом все. Проект удается закрыть только через диспетчер задач.
Возможно, для большинства случаев применения сабклассинга, удобнее использовать метод с выставлением флага в обработчике. Раньше я так и делал и проблем не возникало. Но для моего эксперимента такой способ не подходит и мне нужен был непосредственный вызов.
Суть эксперимента в следующем: Есть сторонний контрол (Grid), который может прокручивать содержимое либо на одну запись, либо на страницу. Никаких опций настройки скроллинга у него нет. Так вот, посредством сабклассинга хотел перехватывать сообщение WM_MOUSEWHEEL и вызывать дефолтную процедуру, не один раз, а три раза. По идее это должно приводить к скроллингу содержимого грида сразу на три записи (как мне и нужно по задумке), но вышел облом.

DefCall устанавливается в False? Похоже на то что вызывается процедура по умолчанию через CallDef потом еще CallDef при выходе из обработчика. По умолчанию DefCall = True. Будет проще если будет маленький демо проект с ошибкой.

[ger_kar]

По умолчанию DefCall = True

Именно так. DefCall устанавливается в True перед генерацией события вот в этом фрагменте

Код: Выделить всё

     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

И далее при возврате из обработчика этот флаг проверяется и вызывается DefSubclassProc, если флаг установлен. Я же хотел отказаться от этого механизма и вызывать
DefSubclassProc через метод класса CallDef.
В качестве примера можно использовать тот же самый демо пример, который идет вместе с классом.
Оригинальный код примера (работает без глюка):

Код: Выделить всё

Private Sub FormHook_WndProc( _
            ByVal hWnd As Long, _
            ByVal Msg As Long, _
            ByVal wParam As Long, _
            ByVal lParam As Long, _
            ByRef Ret As Long, _
            ByRef DefCall As Boolean)
   
    Select Case Msg
    Case WM_GETMINMAXINFO
        Dim MinMax As MINMAXINFO

        CopyMemory MinMax, ByVal lParam, Len(MinMax)
        MinMax.ptMaxTrackSize.x = 500   ' Maximum size 500х500
        MinMax.ptMaxTrackSize.y = 500
        MinMax.ptMinTrackSize.x = 250   ' Minimum size 350х350
        MinMax.ptMinTrackSize.y = 250
        CopyMemory ByVal lParam, MinMax, Len(MinMax)
    Case WM_MOUSEWHEEL
        Dim dir As Long

        dir = (wParam And &HFFFF0000) \ &H780000

        WheelValue = WheelValue + dir
        Refresh

    Case Else
        DefCall = True
    End Select

End Sub

Глючный вариант

Код: Выделить всё

Private Sub FormHook_WndProc( _
            ByVal hWnd As Long, _
            ByVal Msg As Long, _
            ByVal wParam As Long, _
            ByVal lParam As Long, _
            ByRef Ret As Long, _
            ByRef DefCall As Boolean)

    Dim Status As Boolean
   
    Select Case Msg
    Case WM_GETMINMAXINFO
        Dim MinMax As MINMAXINFO

        CopyMemory MinMax, ByVal lParam, Len(MinMax)
        MinMax.ptMaxTrackSize.x = 500   ' Maximum size 500х500
        MinMax.ptMaxTrackSize.y = 500
        MinMax.ptMinTrackSize.x = 250   ' Minimum size 350х350
        MinMax.ptMinTrackSize.y = 250
        CopyMemory ByVal lParam, MinMax, Len(MinMax)
    Case WM_MOUSEWHEEL
        Dim dir As Long

        dir = (wParam And &HFFFF0000) \ &H780000

        WheelValue = WheelValue + dir
        Refresh

    Case Else
        DefCall = False
        FormHook.CallDef hWnd, Msg, wParam, lParam, Status
    End Select

Разница в том, что я выставляю DefCall = False и вызываю непосредственно метод CallDef, плюс для вызова метода добавлена переменная Status.

Я конечно могу и свой проектик скинуть, но тогда придется и библиотеку с контролами высылать и базу данных и библиотеку провайдера. Хотя, для воспроизведения глюка, достаточно того демо примера, который поставляется с кирпичем.
Самый минимум, для воспроизводства глюка - это обработчик с прямым вызовом метода CallDef

Код: Выделить всё

Private Sub FormHook_WndProc( _
            ByVal hWnd As Long, _
            ByVal Msg As Long, _
            ByVal wParam As Long, _
            ByVal lParam As Long, _
            ByRef Ret As Long, _
            ByRef DefCall As Boolean)

    Dim Status As Boolean
   
    DefCall = False
    FormHook.CallDef hWnd, Msg, wParam, lParam, Status
   

End Sub

[ger_kar]

Если отказаться от DefCall = False, то тоже глючит и среда вылетает с ошибкой

Ошибка.png (10.85 Кб) Просмотров: 2021

[The trick]

Самый минимум, для воспроизводства глюка - это обработчик с прямым вызовом метода CallDef

Так ведь нужно возвращать значение:

Код: Выделить всё

Private Sub FormHook_WndProc( _
            ByVal hWnd As Long, _
            ByVal Msg As Long, _
            ByVal wParam As Long, _
            ByVal lParam As Long, _
            ByRef Ret As Long, _
            ByRef DefCall As Boolean)

    Select Case Msg
    Case WM_GETMINMAXINFO
        Dim MinMax As MINMAXINFO

        CopyMemory MinMax, ByVal lParam, Len(MinMax)
        MinMax.ptMaxTrackSize.x = 500   ' Maximum size 500õ500
        MinMax.ptMaxTrackSize.y = 500
        MinMax.ptMinTrackSize.x = 250   ' Minimum size 350õ350
        MinMax.ptMinTrackSize.y = 250
        CopyMemory ByVal lParam, MinMax, Len(MinMax)
    Case WM_MOUSEWHEEL
        Dim dir As Long

        dir = (wParam And &HFFFF0000) \ &H780000

        WheelValue = WheelValue + dir
        Refresh

    Case Else
   
        DefCall = False
       
        Ret = FormHook.CallDef(hWnd, Msg, wParam, lParam, False)
       
    End Select

End Sub

[ger_kar]

Блин! Точно! Вот я затупил на ровном месте
Я кстати еще подумал, что разница в вызовах в том, что при вызове посредством установки флага возвращается значение, а я ничего не возвращаю. На Ret в передаваемых аргументах я внимания как то не обратил и полез читать про функцию DefSubclassProc (с переводчиком).
Прочитал следующее:

Возвращаемое значение
Тип: LRESULT
Возвращаемое значение зависит от отправленного сообщения. Это значение следует игнорировать.

Ну игнорировать, так игнорировать и что то дальше не стал копать в этом направлении. Забил на возврат значения, по рекомендации.

Спасибо. Все оказалось элементарно.