Не могу разобраться с сабклассером из кирпичей... Помогите

Программирование на Visual Basic, главный форум. Обсуждение тем программирования на VB 1—6.
Даже если вы плохо разбираетесь в VB и программировании вообще — тут вам помогут. В разумных пределах, конечно.
Правила форума
Темы, в которых будет сначала написано «что нужно сделать», а затем просьба «помогите», будут закрыты.
Читайте требования к создаваемым темам.
lister
Постоялец
Постоялец
Аватара пользователя
 
Сообщения: 389
Зарегистрирован: 15.01.2005 (Сб) 7:34
Откуда: Страна оления

Не могу разобраться с сабклассером из кирпичей... Помогите

Сообщение lister » 18.08.2006 (Пт) 1:58

Ситуация следующая:

Имеется VB6 SP6

Для наглядного отображения моей проблемы создан ActiveX Control-проект, состоящий:

UserControl=UserControl1.ctl
Module=SubClasser; SubClasser.bas
Class=ISubclass; ISubclass.cls
Class=SubClassItem; SubClassItem.cls

Модули и классы сабклассера - из кирпичного завода...

Код UserControl'а:

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

Implements ISubclass

Private Const WM_MOUSEHOVER As Long = &H2A1
Private Const WM_MOUSELEAVE As Long = &H2A3
Private Const WM_MOUSEMOVE As Long = &H200

Private Const TME_HOVER As Long = 1
Private Const TME_LEAVE As Long = 2

Private Type tagTRACKMOUSEEVENT
  cbSize As Long
  dwFlags As Long
  hwndTrack As Long
  dwHoverTime As Long
End Type


Private Declare Function TrackMouseEvent Lib "user32.dll" ( _
   ByRef lpEventTrack As tagTRACKMOUSEEVENT) As Long


Public Event MouseHover()
Public Event MouseLeave()

Private m_blnHot As Boolean

Private Function ISubclass_Callback(ByVal hWnd As Long, uMsg As Long, wParam As Long, lParam As Long, ByVal PrevProc As Long) As Long
  Dim typTME As tagTRACKMOUSEEVENT
 
  Select Case uMsg
    Case WM_MOUSEHOVER
      m_blnHot = True
      RaiseEvent MouseHover
     
    Case WM_MOUSELEAVE
      m_blnHot = False
      RaiseEvent MouseLeave

    Case WM_MOUSEMOVE
      If Not m_blnHot Then

        With typTME
           .cbSize = LenB(typTME)
           .hwndTrack = hWnd
           .dwFlags = TME_HOVER Or TME_LEAVE
           .dwHoverTime = 1

        End With

        TrackMouseEvent typTME

      End If
     
    Case Else
      ISubclass_Callback = SubClasser.CallWindowProc(PrevProc, hWnd, uMsg, wParam, lParam)

  End Select
 
End Function

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  SubClasser.AddSubclassHook hWnd, Me, DoNotTransfer
 
End Sub

Private Sub UserControl_Terminate()
  SubClasser.RemoveSubclassHook hWnd

End Sub



Благополучно создается project1.ocx...


Затем создается проект Standart EXE, на форму которого помещается созданный контрол и надпись Label1

Код формы Form1

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

Private Sub UserControl11_MouseHover()
  Label1 = "MouseHover"
 
End Sub

Private Sub UserControl11_MouseLeave()
  Label1 = "MouseLeave"

End Sub


Проект запускается в IDE, работает... вроде все нормально...

Компилируется vb6projectProject1.exe

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

Но как только окно закрывается, вылетает ошибка
AppName: vb6projectproject1.exe AppVer: 0.0.0.0 ModName: kernel32.dll
ModVer: 5.1.2600.2945 Offset: 00012a5b

И не понятно, почему...

Вот надеюсь, что кто-нибудь все-таки поможет :shock:
Вложения
TestSubclasser.zip
Прикрепляю проекты
(20.73 Кб) Скачиваний: 122

tyomitch
Пользователь #1352
Пользователь #1352
Аватара пользователя
 
Сообщения: 12822
Зарегистрирован: 20.10.2002 (Вс) 17:02
Откуда: חיפה

Сообщение tyomitch » 18.08.2006 (Пт) 13:36

Вот фикс.
Код: Выделить всё
Private Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  Dim objCurHook As SubClassItem
 
  On Error Resume Next 'GSerg-у низачот
  Set objCurHook = m_colMembers(CStr(hWnd))
  On Error GoTo 0 'PrevWindowProc потерян, ничего не остаётся, кроме как выйти
  If objCurHook Is Nothing Then Exit Function
 
  Select Case objCurHook.TransferHow
  ....
Изображение

lister
Постоялец
Постоялец
Аватара пользователя
 
Сообщения: 389
Зарегистрирован: 15.01.2005 (Сб) 7:34
Откуда: Страна оления

Сообщение lister » 18.08.2006 (Пт) 16:27

Ура :P Разрешилось наконец-таки...

tyomitch, спасибо огромное!

Надеюсь, GSerg исправит оный кирпич ;)

GSerg
Шаман
Шаман
 
Сообщения: 14286
Зарегистрирован: 14.12.2002 (Сб) 5:25
Откуда: Магадан

Сообщение GSerg » 18.08.2006 (Пт) 22:34

Хм.
Помнится, я тогда давно когда это писал, специально над этим думал, и мне показалось, что такой ситуации не должно возникать.
Как только вы переберёте все варианты решения и не найдёте нужного, тут же обнаружится решение, простое и очевидное для всех, кроме вас

tyomitch
Пользователь #1352
Пользователь #1352
Аватара пользователя
 
Сообщения: 12822
Зарегистрирован: 20.10.2002 (Вс) 17:02
Откуда: חיפה

Сообщение tyomitch » 18.08.2006 (Пт) 23:12

Тут, похоже, дело в том, что коллекция за твоей спиной уничтожается и при обращении вовь создаётся. Попробуй определить её без As New и проверять в WindowProc, есть она ещё или уже нет. Я на сегодня уже надебажился выше крыши :-)
Изображение


Вернуться в Visual Basic 1–6

Кто сейчас на конференции

Сейчас этот форум просматривают: AhrefsBot, Majestic-12 [Bot], Yandex-бот и гости: 13

    TopList